From b4f50665ec82108168540f3b25facf583fd661cb Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Wed, 12 May 2021 11:07:56 +1200 Subject: [PATCH 01/25] reducing the dimension of 'arclength' array and removing 'parentlist' from the global parameters. 'calc_scale_factors_2d' rewritten to be more specific to the surface meshes used in the code, along with specific functions for 'hermite' and 'linear' interpolation --- src/lib/arrays.f90 | 5 +- src/lib/mesh_utilities.f90 | 291 +++++++++++++++++-------------------- 2 files changed, 134 insertions(+), 162 deletions(-) diff --git a/src/lib/arrays.f90 b/src/lib/arrays.f90 index d9070cd6..22d5ca30 100644 --- a/src/lib/arrays.f90 +++ b/src/lib/arrays.f90 @@ -21,7 +21,6 @@ module arrays integer,allocatable :: node_versn_2d(:) !allocated in define_node_geometry_2d integer,allocatable :: elems(:) !allocated in define_1d_elements integer,allocatable :: lines_2d(:) - integer,allocatable :: parentlist(:) integer,allocatable :: line_versn_2d(:,:,:) integer,allocatable :: lines_in_elem(:,:) integer,allocatable :: nodes_in_line(:,:,:) @@ -39,7 +38,7 @@ module arrays integer,allocatable :: elems_at_node_2d(:,:) integer,allocatable :: units(:) - real(dp),allocatable :: arclength(:,:) + real(dp),allocatable :: arclength(:) real(dp),allocatable :: elem_field(:,:) !properties of elements real(dp),allocatable :: elem_direction(:,:) real(dp),allocatable :: node_xyz(:,:) @@ -120,7 +119,7 @@ module arrays elem_units_below, maxgen,capillary_bf_parameters, zero_tol,loose_tol,gasex_field, & num_lines_2d, lines_2d, line_versn_2d, lines_in_elem, nodes_in_line, elems_2d, & elem_cnct_2d, elem_nodes_2d, elem_versn_2d, elem_lines_2d, elems_at_node_2d, arclength, & - scale_factors_2d, parentlist, fluid_properties, elasticity_vessels, admittance_param, & + scale_factors_2d, fluid_properties, elasticity_vessels, admittance_param, & elasticity_param, all_admit_param contains diff --git a/src/lib/mesh_utilities.f90 b/src/lib/mesh_utilities.f90 index d377c8ff..b675a49e 100644 --- a/src/lib/mesh_utilities.f90 +++ b/src/lib/mesh_utilities.f90 @@ -31,11 +31,11 @@ module mesh_utilities distance_from_plane_to_point, & get_local_elem_2d, & group_elem_by_parent, & + hermite, & inlist, & + linear, & make_plane_from_3points, & mesh_a_x_eq_b, & - ph3, & - pl1, & point_internal_to_surface, & scalar_product_3, & scalar_triple_product, & @@ -95,6 +95,77 @@ module mesh_utilities ! vector_length *** ! .... Calculates the length of a 3x1 vector +!!!##################################################################### + + subroutine calc_arclengths + !*calc_arclengths*: estimates arclength for cubic Hermite using + ! Gaussian quadrature with 4 points + + ! Local variables + integer :: i,it,itmax,n,ng,nj,nl,nline,np,nv,xi_direction + real(dp) :: est_length,incr_length,linear_est,line_xyz(2,3,2), & + local_deriv(3),weight(4),xigg(4) + + xigg = [0.0694318442029_dp, 0.3300094782075_dp,& + 0.6699905217924_dp, 0.9305681557970_dp] ! exact Gauss point locations + weight = [0.1739274225687_dp, 0.3260725774313_dp,& + 0.3260725774313_dp, 0.1739274225687_dp] ! exact Gauss point weightings + + do nline = 1,num_lines_2d ! loop over all lines + nl = lines_2d(nline) ! the line number + xi_direction = nodes_in_line(1,0,nl) ! the Xi direction of the line + + ! get the nodal coordinates and derivatives for the line + do n = 1,2 ! for each node on the line + np = nodes_in_line(n+1,1,nl) ! the first and second node (np1,np2) + nv = line_versn_2d(N,1,nl) ! the version of the node for this line + line_xyz(1,:,n) = node_xyz_2d(1,nv,:,np) ! get the coordinates for the line + if(xi_direction.eq.1) line_xyz(2,:,n) = node_xyz_2d(2,nv,:,np) ! dxi1 + if(xi_direction.eq.2) line_xyz(2,:,n) = node_xyz_2d(3,nv,:,np) ! dxi2 + enddo !n + + ! calculate the linear distance between start and end nodes. this should be + ! used to check that the derivatives are appropriate when the start and + ! end nodes are coincident (i.e. a collapsed element). + est_length = 0.0_dp + do ng = 1,4 + ! calculate the arclength derivatives + do nj = 1,3 + ! local_deriv = phi_10' * xyz_1 + phi_20' * xyz_2 + local_deriv(nj) = linear(1,2,xigg(ng))*line_xyz(1,nj,1) & + + linear(2,2,xigg(ng))*line_xyz(1,nj,2) + enddo + incr_length = sqrt(scalar_product_3(local_deriv,local_deriv)) + est_length = est_length + weight(ng) * incr_length + enddo !ng + + linear_est = est_length + + est_length = 0.0_dp + do ng = 1,4 + ! calculate the arclength derivatives at Xi coordinates + do nj = 1,3 + !function' = phi_10'*xyz_1 + phi_11'*deriv_1 + phi_20'*xyz_2 + phi_21'*deriv_2 + local_deriv(nj) = hermite(1,1,2,xigg(ng))*line_xyz(1,nj,1) & + + hermite(1,2,2,xigg(ng))*line_xyz(2,nj,1) & + + hermite(2,1,2,xigg(ng))*line_xyz(1,nj,2) & + + hermite(2,2,2,xigg(ng))*line_xyz(2,nj,2) + enddo + incr_length = sqrt(scalar_product_3(local_deriv,local_deriv)) + est_length = est_length + weight(ng) * incr_length + enddo !ng + if(abs(linear_est).gt.zero_tol)then + arclength(nl) = est_length + else + arclength(nl) = 0.0_dp + np = nodes_in_line(2,1,nl) ! the first node + nv = line_versn_2d(1,1,nl) ! the version of the node for this line + node_xyz_2d(xi_direction+1,nv,:,np) = 0.0_dp + endif + enddo !loop over lines + + end subroutine calc_arclengths + !!!##################################################################### subroutine calc_branch_direction(ne) @@ -117,143 +188,45 @@ end subroutine calc_branch_direction !!! ########################################################################## subroutine calc_scale_factors_2d(sf_option) - -!!! calculates the arclengths and scale factors for 2d surface elements, -!!! stores in scale_factors_2d + !*calc_scale_factors_2d*: calculates arclengths using Gaussian quadrature, + ! and scale factors for 2d surface elements character(len=4),intent(in) :: sf_option !!! local variables integer,parameter :: num_deriv = 4 - integer :: ido(num_deriv,2),IG(4),it,IT_count,ITMAX=20,k,N,NAE,ne,& - ng,NGA=4,NI1(3),ni,ni2,nj,nk,nk2,nl,nn,nn2,NNK,no_nl,& + integer :: i,ido(num_deriv,2),it,ITMAX=20,k,N,NAE,ne,& + ng,NGA=4,NI1(3),ni,ni2,nj,nk,nk2,nl,nline,nn,nn2,NNK,& np,ns,nv,NNL(2,4) - real(dp) :: DA,SUM1,SUM2,SUM3,SUM4,W,WG_LOCAL(10),XA_LOCAL(4,3),XI,& - XIGG(10),XN_LOCAL(2,3,4) + real(dp) :: DA,SUM1,SUM2,SUM3,SUM4,W logical :: FOUND - XIGG = [0.6_dp,0.2113248654051_dp,0.7886751345948_dp,0.1127016653792_dp,& - 0.6_dp,0.8872983346207_dp,0.0694318442029_dp,0.3300094782075_dp,& - 0.6699905217924_dp,0.9305681557970_dp] - WG_LOCAL = [1.0_dp,0.6_dp,0.6_dp,0.2777777777778_dp,0.4444444444444_dp,& - 0.2777777777778_dp,0.1739274225687_dp,0.3260725774313_dp,& - 0.3260725774313_dp,0.1739274225687_dp] - IG = [0,1,3,6] ido = reshape ([1,2,1,2,1,1,2,2],shape(ido)) NI1 = [1,2,1] NNL = reshape([1,2,3,4,1,3,2,4],shape(NNL)) - + + if(.not.allocated(scale_factors_2d)) allocate(scale_factors_2d(16,num_elems_2d)) select case (sf_option) case ('unit') scale_factors_2d = 1.0_dp + case('arcl') - do no_nl=1,num_lines_2d !loop over global lines - nl=lines_2d(no_nl) - ni = nodes_in_line(1,0,nl) - do n = 1,2 !for each node on the line - np = nodes_in_line(n+1,1,nl) !np1,np2 - do nj = 1,3 - nv = line_versn_2d(N,nj,nl) - XN_LOCAL(1,nj,n) = node_xyz_2d(1,nv,nj,np) - ne = lines_in_elem(1,nl) - ni2 = 1+MOD(ni,2) - nn = 1 - FOUND =.FALSE. - do WHILE((nn.LE.4).AND.(.NOT.FOUND)) - if(np.EQ.elem_nodes_2d(nn,ne))then - FOUND=.TRUE. - else - nn=nn+1 - endif - enddo - do nk=2,4 !dxi1, dxi2, d2xi1xi2 - if(IDO(nk,ni).EQ.2.AND.IDO(nk,ni2).EQ.1) then - XN_LOCAL(2,nj,n) = node_xyz_2d(nk,nv,nj,np) - endif - enddo !nk - enddo !nj - enddo !n - - SUM2=0.0_dp - do ng=1,NGA - XI=XIGG(IG(NGA)+ng) - W=WG_LOCAL(IG(NGA)+ng) - do nj=1,3 - do k=1,2 - XA_LOCAL(k,nj)=PL1(1,k,XI)*XN_LOCAL(1,nj,1) & - +PL1(2,k,XI)*XN_LOCAL(1,nj,2) - enddo - enddo - - SUM1=XA_LOCAL(2,1)**2+XA_LOCAL(2,2)**2+XA_LOCAL(2,3)**2 - SUM2=SUM2+W*DSQRT(SUM1) - enddo !ng - - arclength(1:3,nl)=SUM2 - - it=0 - iterative_loop : do - it=it+1 - IT_count=it - SUM3=0.0_dp - SUM4=0.0_dp - do ng=1,NGA - XI=XIGG(IG(NGA)+ng) - W=WG_LOCAL(IG(NGA)+ng) - do nj=1,3 - do k=1,2 - XA_LOCAL(k,nj)=0.0_dp - do n=1,2 - XA_LOCAL(k,nj)=XA_LOCAL(k,nj)+ & - PH3(n,1,k,XI)*XN_LOCAL(1,nj,n) & - +PH3(n,2,k,XI)*XN_LOCAL(2,nj,n)*arclength(n,nl) - enddo - enddo - XA_LOCAL(3,nj)=0.0_dp - do n=1,2 - XA_LOCAL(3,nj)=XA_LOCAL(3,nj)+ & - PH3(n,2,2,XI)*XN_LOCAL(2,nj,n) - enddo - XA_LOCAL(4,nj)=0.0_dp - do n=1,2 - XA_LOCAL(4,nj)=XA_LOCAL(4,nj)+ & - PH3(n,2,1,XI)*XN_LOCAL(2,nj,n) - enddo - enddo - SUM1=XA_LOCAL(2,1)**2+XA_LOCAL(2,2)**2+XA_LOCAL(2,3)**2 - SUM2=0.0_dp - do nj=1,3 - SUM2=SUM2+XA_LOCAL(2,nj)*XA_LOCAL(3,nj) - enddo !nj - SUM3=SUM3+W*DSQRT(SUM1) - if(SUM1.GT.1.0e-6_dp) SUM4=SUM4+W*SUM2/DSQRT(SUM1) - enddo !ng - DA=-(arclength(3,nl)-SUM3)/(1.0_dp-SUM4) - if(DABS(DA).GT.1.0e+6_dp) then - arclength(3,nl)=1.0_dp - exit iterative_loop - endif - - arclength(3,nl) = arclength(3,nl)+DA !is new arclength - arclength(1:2,nl) = arclength(3,nl) - - if(it.eq.ITMAX) exit iterative_loop - - enddo iterative_loop !iteration - enddo !loop over lines + + call calc_arclengths + ! calculate scale factors using the line derivatives scale_factors_2d = 1.0_dp !initialise - do ne=1,num_elems_2d - do NAE=1,4 - nl = elem_lines_2d(NAE,ne) - if(nl /= 0)then - ni = nodes_in_line(1,0,nl) - ni2 = NI1(ni+1) + do ne = 1,num_elems_2d + do NAE = 1,4 ! for each of the (up to) 4 lines in the element + nl = elem_lines_2d(NAE,ne) ! the line number + if(nl /= 0)then ! required for collapsed edges + ni = nodes_in_line(1,0,nl) ! the Xi direction of the line + ni2 = NI1(ni+1) ! 2,1 for Xi 1,2 resp. do N=1,2 - nn=NNL(N,NAE) - ns=0 + nn=NNL(N,NAE) ! 1,2,3,4 for n=1; 1,3,2,4 for n=2 + ns=0 do nn2=1,nn-1 do nk2=1,num_deriv ns=ns+1 @@ -261,19 +234,16 @@ subroutine calc_scale_factors_2d(sf_option) enddo do nk=2,num_deriv if(IDO(nk,ni2).EQ.1) then - scale_factors_2d(nk+ns,ne) = arclength(N,nl) - if(DABS(scale_factors_2d(nk+ns,ne)).LT.1.0e-6_dp) scale_factors_2d(nk+ns,ne) = 1.0_dp + scale_factors_2d(nk+ns,ne) = arclength(nl) + if(abs(scale_factors_2d(nk+ns,ne)).LT.1.0e-6_dp) scale_factors_2d(nk+ns,ne) = 1.0_dp endif enddo !nk enddo !N=1,2 endif enddo !NAE (nl) - - NNK=0 - do ns=1,4 - scale_factors_2d(NNK+4,ne)=scale_factors_2d(NNK+2,ne)*scale_factors_2d(NNK+3,ne) - NNK=NNK+4 - enddo !nn + + forall(i = 0:12:4) scale_factors_2d(i+4,ne) = scale_factors_2d(i+2,ne)* & + scale_factors_2d(i+3,ne) enddo !noelem (ne) end select @@ -471,74 +441,77 @@ end function inlist !!! ########################################################################## - function ph3(I,J,K,XI) + function hermite(i,j,k,xi) + !*hermite*: evaluates the cubic Hermite basis function at xi. the function + ! is returned for values(k=1) or first(k=2) or second(k=3) derivatives, at + ! xi=0 (i=1) or xi=1 (i=2). -!!! dummy arguments - integer :: I,I_J_K,J,K - real(dp) :: XI + integer,intent(in) :: i,j,k + real(dp) :: xi !!! local variables - real(dp) :: ph3 + integer :: i_j_k + real(dp) :: hermite ! K is 1,2, or 3; J is 1 or 2; I is 1 or 2 - I_J_K = 100*I + 10*J + K + i_j_k = 100*i + 10*j + k - select case(I_J_K) + select case(i_j_k) case(111) !i=1,j=1,k=1 - PH3=(2.0_dp*XI-3.0_dp)*XI*XI+1.0_dp ! 2xi^3-3xi^2+1 + hermite = 1.0_dp - 3.0_dp*xi**2 + 2.0_dp*xi**3 ! phi_10 = 1 -3xi^2 + 2xi^3 case(121) !i=1,j=2,k=1 - PH3=((XI-2.0_dp)*XI+1.0_dp)*XI ! xi^3-2xi^2+xi + hermite = xi*(xi - 1.0_dp)**2 ! phi_11 = xi(xi - 1)^2 case(211) !i=2,j=1,k=1 - PH3=XI*XI*(3.0_dp-2.0_dp*XI) ! -2xi^3+3xi^2 + hermite = xi**2 *(3.0_dp - 2.0_dp*xi) ! phi_20 = xi^2(3 - 2xi) case(221) !i=2,j=2,k=1 - PH3=XI*XI*(XI-1.0_dp) ! xi^3-xi^2 + hermite = xi**2 *(xi - 1.0_dp) ! phi_21 = xi^2(xi - 1) case(112) !i=1,j=1,k=2 - PH3=6.0_dp*XI*(XI-1.0_dp) ! 6xi^2-6xi + hermite = 6.0_dp*xi *(xi - 1.0_dp) ! phi_10' = 6xi(xi - 1) case(122) !i=1,j=2,k=2 - PH3=(3.0_dp*XI-4.0_dp)*XI+1.0_dp ! 3xi^2-4xi+1 + hermite = 3.0_dp*xi**2 - 4.0_dp*xi + 1.0_dp ! phi_11' = 3xi^2-4xi+1 case(212) !i=2,j=1,k=2 - PH3=6.0_dp*XI*(1.0_dp-XI) ! -6xi^2+6xi + hermite = 6.0_dp*xi*(1.0_dp - xi) ! phi_20' = 6xi-6xi^2 case(222) !i=2,j=2,k=2 - PH3=XI*(3.0_dp*XI-2.0_dp) ! 3xi^2-2xi + hermite = xi*(3.0_dp*xi - 2.0_dp) ! phi_21' = 3xi^2-2xi case(113) !i=1,j=1,k=3 - PH3=12.0_dp*XI-6.0_dp ! 12xi-6 + hermite = 6.0_dp*(2.0_dp*xi - 1.0_dp) ! phi_10'' = 12xi-6 case(123) !i=1,j=2,k=3 - PH3=6.0_dp*XI-4.0_dp ! 6xi-4 + hermite = 6.0_dp*xi - 4.0_dp ! phi_11'' = 6xi-4 case(213) !i=2,j=1,k=3 - PH3=6.0_dp-12.0_dp*XI ! -12xi+6 + hermite = 6.0_dp - 12.0_dp*xi ! phi_20'' = -12xi+6 case(223) !i=2,j=2,k=3 - PH3=6.0_dp*XI-2.0_dp ! 6xi-2 + hermite = 6.0_dp*xi - 2.0_dp ! phi_21'' = 6xi-2 end select - end function ph3 + end function hermite !!! ########################################################################## - function pl1(I,K,XI) + function linear(i,k,xi) -!!! dummy arguments - integer :: I,I_K,K - real(dp) :: XI + integer,intent(in) :: i,k + real(dp),intent(in) :: xi !!! local variables - real(dp) :: pl1 + integer :: i_k + real(dp) :: linear - I_K = 10*I + K + i_k = 10*i + k select case(I_K) case(11) !i=1,k=1 - PL1=1.0_dp-XI + linear = 1.0_dp-xi ! phi_10 = 1-xi case(21) !i=2,k=1 - PL1=XI + linear = xi ! phi_20 = xi case(12) !i=1,k=2 - PL1=-1.0_dp + linear = -1.0_dp ! phi_10' = -1 case(22) !i=2,k=2 - PL1=1.0_dp + linear = 1.0_dp ! phi_20' = 1 case(30 :) !k=3 - PL1=0.0_dp + linear = 0.0_dp ! phi_10''= phi_20'' = 0 end select return - end function pl1 + end function linear !!!################################################## From 428f305f8728729ff32770ab474f21ec22b859d5 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Wed, 12 May 2021 11:39:16 +1200 Subject: [PATCH 02/25] new subroutine 'import_node_geometry_2d' and its bindings --- src/bindings/c/geometry.c | 7 +++ src/bindings/c/geometry.f90 | 25 ++++++++++ src/bindings/c/geometry.h | 1 + src/bindings/interface/geometry.i | 1 + src/lib/geometry.f90 | 82 +++++++++++++++++++++++++++++++ 5 files changed, 116 insertions(+) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index f37746cc..521596aa 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -13,6 +13,7 @@ void define_node_geometry_c(const char *NODEFILE, int *filename_len); void define_node_geometry_2d_c(const char *NODEFILE, int *filename_len); void define_data_geometry_c(const char *DATAFILE, int *filename_len); extern void grow_tree_c(int *elemlist_len, int elemlist[], int *parent_ne, double *angle_max, double *angle_min, double *branch_fraction, double *length_limit, double *shortest_length, double *rotation_limit); +void import_node_geometry_2d_c(const char *NODEFILE, int *filename_len); extern void make_data_grid_c(int *elemlist_len, int elemlist[], double *offset, double *spacing, const char *filename, int *filename_len, const char *groupname, int *groupname_len); extern void make_2d_vessel_from_1d_c(int *elemlist_len, int elemlist[]); void define_rad_from_file_c(const char *FIELDFILE, int *filename_len, const char *radius_type, int *radius_type_len); @@ -85,6 +86,12 @@ void grow_tree(int elemlist_len, int elemlist[], int parent_ne, double angle_max grow_tree_c(&elemlist_len, elemlist, &parent_ne, &angle_max, &angle_min, &branch_fraction, &length_limit, &shortest_length, &rotation_limit); } +void import_node_geometry_2d(const char *NODEFILE) +{ + int filename_len = (int)strlen(NODEFILE); + import_node_geometry_2d_c(NODEFILE, &filename_len); +} + void make_data_grid(int elemlist_len, int elemlist[], double offset, double spacing, const char *filename, const char *groupname) { int filename_len = (int)strlen(filename); diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index c50a44aa..d0ce41e2 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -189,6 +189,31 @@ subroutine grow_tree_c(surface_elems_len, surface_elems, parent_ne, & end subroutine grow_tree_c +! +!################################################################################### +! + subroutine import_node_geometry_2d_c(NODEFILE, filename_len) bind(C, name="import_node_geometry_2d_c") + + use iso_c_binding, only: c_ptr + use utils_c, only: strncpy + use other_consts, only: MAX_FILENAME_LEN + use geometry, only: import_node_geometry_2d + implicit none + + integer,intent(in) :: filename_len + type(c_ptr), value, intent(in) :: NODEFILE + character(len=MAX_FILENAME_LEN) :: filename_f + + call strncpy(filename_f, NODEFILE, filename_len) + +#if defined _WIN32 && defined __INTEL_COMPILER + call so_import_node_geometry_2d(filename_f) +#else + call import_node_geometry_2d(filename_f) +#endif + + end subroutine import_node_geometry_2d_c + ! !################################################################################### ! diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index 0f743bdb..e2ebe478 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -14,6 +14,7 @@ SHO_PUBLIC void define_node_geometry(const char *NODEFILE); SHO_PUBLIC void define_node_geometry_2d(const char *NODEFILE); SHO_PUBLIC void define_data_geometry(const char *DATAFILE); SHO_PUBLIC void grow_tree(int elemlist_len, int elemlist[], int parent_ne, double angle_max, double angle_min, double branch_fraction, double length_limit, double shortest_length, double rotation_limit); +SHO_PUBLIC void import_node_geometry_2d(const char *NODEFILE); SHO_PUBLIC void make_data_grid(int elemlist_len, int elemlist[], double offset, double spacing, const char *filename, const char *groupname); SHO_PUBLIC void make_2d_vessel_from_1d(int elemlist_len, int elemlist[]); SHO_PUBLIC void define_rad_from_file(const char *FIELDFILE, const char *radius_type); diff --git a/src/bindings/interface/geometry.i b/src/bindings/interface/geometry.i index 437ebf6d..28db257e 100644 --- a/src/bindings/interface/geometry.i +++ b/src/bindings/interface/geometry.i @@ -32,6 +32,7 @@ // so we use SWIG to override with a C++ version that can. void define_elem_geometry_2d(const char *ELEMFILE, const char *sf_option="arcl"); void define_node_geometry_2d(const char *NODEFILE); +void import_node_geometry_2d(const char *NODEFILE); void write_elem_geometry_2d(const char *ELEMFILE); void write_geo_file(int ntype, const char *GEOFILE); void write_node_geometry_2d(const char *NODEFILE); diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 2116ac2c..a36b375b 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -43,6 +43,7 @@ module geometry public get_local_node_f public group_elem_parent_term public grow_tree + public import_node_geometry_2d public make_data_grid public make_2d_vessel_from_1d public reallocate_node_elem_arrays @@ -1158,6 +1159,87 @@ subroutine grow_tree(surface_elems,parent_ne,angle_max,angle_min,& end subroutine grow_tree +!!!############################################################################# + + subroutine import_node_geometry_2d(NODEFILE) + !*define_node_geometry_2d:* Reads in an exnode file to define surface nodes + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_DEFINE_NODE_GEOMETRY_2D" :: DEFINE_NODE_GEOMETRY_2D + + character(len=*),intent(in) :: NODEFILE + ! Local Variables + integer :: i,ierror,index_location,np,np_global,num_versions,nv + character(len=132) :: ctemp1,readfile + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'import_node_geometry_2d' + call enter_exit(sub_name,1) + + if(index(NODEFILE, ".exnode")> 0) then !full filename is given + readfile = NODEFILE + else ! need to append the correct filename extension + readfile = trim(NODEFILE)//'.exnode' + endif + + open(10, file=readfile, status='old') + + !.....get the total number of nodes. + num_nodes_2d = 0 + read_number_of_nodes : do !define a do loop name + read(unit=10, fmt="(a)", iostat=ierror) ctemp1 !read a line into ctemp1 + if(ierror<0) exit !ierror<0 means end of file + if(index(ctemp1, "Node:")> 0) then !keyword "Node:" is found in ctemp1 + num_nodes_2d = num_nodes_2d+1 + endif + end do read_number_of_nodes + close(10) + +!!!allocate memory to arrays that require node number + if(.not.allocated(nodes_2d)) allocate(nodes_2d(num_nodes_2d)) + if(.not.allocated(node_xyz_2d)) allocate(node_xyz_2d(4,10,3,num_nodes_2d)) + if(.not.allocated(node_versn_2d)) allocate(node_versn_2d(num_nodes_2d)) + nodes_2d = 0 + node_xyz_2d = 0.0_dp + node_versn_2d = 0 + + !.....read the coordinate, derivative, and version information for each node. + open(10, file=readfile, status='old') + np = 0 + num_versions = 1 + read_a_node : do !define a do loop name + !.......read node number + read(unit=10, fmt="(a)", iostat=ierror) ctemp1 + if(index(ctemp1, "Derivatives") > 0)then + index_location = index(ctemp1, "Versions") + if(index_location > 0) then + read(ctemp1(index_location+9:index_location+10), '(i2)', iostat=ierror) num_versions + else + num_versions = 1 ! the default + endif + endif + if(index(ctemp1, "Node:")> 0) then + np_global = get_final_integer(ctemp1) !get node number + np = np+1 + nodes_2d(np) = np_global + node_versn_2d(np) = num_versions + + !.......read coordinates + do i =1,3 ! for the x,y,z coordinates + do nv = 1,node_versn_2d(np) + read(unit=10, fmt=*, iostat=ierror) node_xyz_2d(1:4,nv,i,np) + end do !nv + end do !i + endif !index + if(np.ge.num_nodes_2d) exit read_a_node + end do read_a_node + + close(10) + + call enter_exit(sub_name,2) + + end subroutine import_node_geometry_2d + !!!############################################################################# subroutine triangles_from_surface(num_triangles,num_vertices,surface_elems, & From 5472ae5e4348aa900d240cb5d5c5b38466572183 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Wed, 12 May 2021 17:09:13 +1200 Subject: [PATCH 03/25] surface fitting including python bindings. Includes subroutines to adjust the location of specified nodes so that they remain on the fitted surface but are spread evenly between user-specified nodes --- src/bindings/c/CMakeLists.txt | 3 + src/bindings/c/surface_fitting.c | 6 +- src/bindings/c/surface_fitting.f90 | 15 +- src/bindings/c/surface_fitting.h | 1 + src/bindings/interface/surface_fitting.i | 3 + src/bindings/python/CMakeLists.txt | 1 + src/lib/CMakeLists.txt | 1 + src/lib/geometry.f90 | 2 +- src/lib/mesh_utilities.f90 | 1 + src/lib/surface_fitting.f90 | 1766 +++++++++++++--------- 10 files changed, 1097 insertions(+), 702 deletions(-) diff --git a/src/bindings/c/CMakeLists.txt b/src/bindings/c/CMakeLists.txt index e2e2ff32..d359be6e 100644 --- a/src/bindings/c/CMakeLists.txt +++ b/src/bindings/c/CMakeLists.txt @@ -15,6 +15,7 @@ set(C_FORTRAN_LIB_SRCS imports.f90 pressure_resistance_flow.f90 species_transport.f90 + surface_fitting.f90 utils.f90 ventilation.f90 wave_transmission.f90 @@ -34,6 +35,7 @@ set(C_C_LIB_SRCS imports.c pressure_resistance_flow.c species_transport.c + surface_fitting.c utils.c ventilation.c wave_transmission.c @@ -54,6 +56,7 @@ set(C_LIB_HDRS imports.h pressure_resistance_flow.h species_transport.h + surface_fitting.h utils.h ventilation.h wave_transmission.h diff --git a/src/bindings/c/surface_fitting.c b/src/bindings/c/surface_fitting.c index f30b90a9..c4770865 100644 --- a/src/bindings/c/surface_fitting.c +++ b/src/bindings/c/surface_fitting.c @@ -2,7 +2,7 @@ #include "string.h" void fit_surface_geometry_c(int *niterations,const char *fitting_file,int *fitting_file_len); - +void initialise_fit_mesh_c(void); void fit_surface_geometry(int niterations,const char *fitting_file) { @@ -10,4 +10,8 @@ void fit_surface_geometry(int niterations,const char *fitting_file) fit_surface_geometry_c(&niterations, fitting_file, &filename_len); } +void initialise_fit_mesh() +{ + initialise_fit_mesh_c(); +} diff --git a/src/bindings/c/surface_fitting.f90 b/src/bindings/c/surface_fitting.f90 index af564beb..e374b122 100644 --- a/src/bindings/c/surface_fitting.f90 +++ b/src/bindings/c/surface_fitting.f90 @@ -9,7 +9,7 @@ module surface_fitting_c subroutine fit_surface_geometry_c(niterations, fitting_file, filename_len) & bind(C, name="fit_surface_geometry_c") - use iso_c_binding, only: c_ptr + use iso_c_binding, only: c_ptr use utils_c, only: strncpy use other_consts, only: MAX_STRING_LEN, MAX_FILENAME_LEN use surface_fitting, only: fit_surface_geometry @@ -31,4 +31,17 @@ end subroutine fit_surface_geometry_c !!!############################################################################ + subroutine initialise_fit_mesh_c() bind(C, name="initialise_fit_mesh_c") + use surface_fitting, only: initialise_fit_mesh + implicit none + +#if defined _WIN32 && defined __INTEL_COMPILER + call so_initialise_fit_mesh +#else + call initialise_fit_mesh +#endif + + end subroutine initialise_fit_mesh_c + +!!!############################################################################ end module surface_fitting_c diff --git a/src/bindings/c/surface_fitting.h b/src/bindings/c/surface_fitting.h index 76b3b0f3..8b3f565d 100644 --- a/src/bindings/c/surface_fitting.h +++ b/src/bindings/c/surface_fitting.h @@ -4,5 +4,6 @@ #include "symbol_export.h" SHO_PUBLIC void fit_surface_geometry(int niterations, const char *fitting_file); +SHO_PUBLIC void initialise_fit_mesh(); #endif /* AETHER_SURFACE_FITTING_H */ diff --git a/src/bindings/interface/surface_fitting.i b/src/bindings/interface/surface_fitting.i index 0b98241e..c6de37b1 100644 --- a/src/bindings/interface/surface_fitting.i +++ b/src/bindings/interface/surface_fitting.i @@ -7,4 +7,7 @@ #include "surface_fitting.h" %} +void fit_surface_geometry(int niterations, const char *fitting_file); +void initialise_fit_mesh(); + diff --git a/src/bindings/python/CMakeLists.txt b/src/bindings/python/CMakeLists.txt index 5d72df0f..f354cebe 100644 --- a/src/bindings/python/CMakeLists.txt +++ b/src/bindings/python/CMakeLists.txt @@ -31,6 +31,7 @@ set(INTERFACE_SRCS ../interface/imports.i ../interface/pressure_resistance_flow.i ../interface/species_transport.i + ../interface/surface_fitting.i ../interface/ventilation.i ../interface/wave_transmission.i ) diff --git a/src/lib/CMakeLists.txt b/src/lib/CMakeLists.txt index 6ff55d82..f2464fb8 100644 --- a/src/lib/CMakeLists.txt +++ b/src/lib/CMakeLists.txt @@ -20,6 +20,7 @@ set(LIB_SRCS pressure_resistance_flow.f90 solve.f90 species_transport.f90 + surface_fitting.f90 ventilation.f90 wave_transmission.f90 ) diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index a36b375b..36ecc983 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -2961,7 +2961,7 @@ subroutine line_segments_for_2d_mesh(sf_option) allocate(line_versn_2d(2,3,num_lines_2d)) allocate(lines_in_elem(0:4,num_lines_2d)) allocate(nodes_in_line(3,0:3,num_lines_2d)) - !allocate(arclength(num_lines_2d)) + allocate(arclength(num_lines_2d)) lines_in_elem=0 lines_2d=0 diff --git a/src/lib/mesh_utilities.f90 b/src/lib/mesh_utilities.f90 index b675a49e..0f529763 100644 --- a/src/lib/mesh_utilities.f90 +++ b/src/lib/mesh_utilities.f90 @@ -22,6 +22,7 @@ module mesh_utilities angle_btwn_points, & angle_btwn_vectors, & bifurcation_element, & + calc_arclengths, & calc_branch_direction, & calc_scale_factors_2d, & check_colinear_points, & diff --git a/src/lib/surface_fitting.f90 b/src/lib/surface_fitting.f90 index 54a0c33d..3124a008 100644 --- a/src/lib/surface_fitting.f90 +++ b/src/lib/surface_fitting.f90 @@ -1,15 +1,21 @@ module surface_fitting +!!! This is a non-generalised adaptation of the general geometric fitting +!!! methods from the Auckland Bioengineering Institute's legacy 'CMISS' code. use arrays + use diagnostics use geometry use other_consts - use mesh_functions + use mesh_utilities use precision use solve implicit none - public fit_surface_geometry,pxi + public & + fit_surface_geometry, & + initialise_fit_mesh, & + pxi integer,parameter :: nmax_data_elem = 4000 ! max # data points on an element integer,parameter :: nmax_versn = 6 ! max # versions of node (derivative) @@ -29,25 +35,25 @@ module surface_fitting !!! ########################################################################## subroutine fit_surface_geometry(niterations,fitting_file) - -!!! completes 'niterations' of geometry fitting to a surface, via minimising -!!! the least squares distance between a list of data points (3D RC coordinates) -!!! and a surface mesh (assumed bi-cubic Hermite only). 'fitting_file' lists -!!! the nodes/derivatives that are fixed, and any mapping of nodes and/or -!!! derivatives - -!!! dummy arguments - integer,intent(in) :: niterations ! user-specified number of fitting iterations + !*fit_surface_geometry:* completes 'niterations' of geometry fitting to a + ! surface, via minimising the least squares distance between a list of + ! data points (3D RC coordinates) and a surface mesh (assumed bi-cubic + ! Hermite only). 'fitting_file' lists the nodes/derivatives that are fixed, + ! and any mapping of nodes and/or derivatives + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_FIT_SURFACE_GEOMETRY" :: FIT_SURFACE_GEOMETRY + + integer,intent(in) :: niterations ! user-specified number of fitting iterations character(len=255),intent(in) :: fitting_file ! file that lists versions/mapping/BCs -!!! local variables + ! Local variables integer :: nfit,nk,NOT_1,NOT_2,np,num_depvar,nv,ny_max logical :: first = .true. -!!! local allocatable arrays + ! local allocatable arrays integer,allocatable :: data_elem(:) integer,allocatable :: data_on_elem(:,:) ! list of data closest to elements integer,allocatable :: elem_list(:) ! list of elements in fit (all) integer,allocatable :: ndata_on_elem(:) ! # of data points closest to element integer,allocatable :: npny(:,:) ! maps deriv, vers, node, etc for a dep. variable + integer,allocatable :: np_list_redist(:,:) ! lists of nodes to be uniformly redistributed integer,allocatable :: nynp(:,:,:,:) ! dep. variable # for node, deriv, version etc. integer,allocatable :: nynr(:) ! list of all dep. variables integer,allocatable :: nyny(:,:) ! maps dep. variable to another dep. variable @@ -57,10 +63,17 @@ subroutine fit_surface_geometry(niterations,fitting_file) real(dp),allocatable :: sobelov_wts(:,:) ! Scaling factor for, and Sobelov weights logical,allocatable :: fix_bcs(:) ! logical for boundary conditions + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'fit_surface_geometry' + call enter_exit(sub_name,1) !!! allocate element-sized arrays - allocate(elem_list(0:num_elems_2d)) + allocate(elem_list(num_elems_2d)) allocate(sobelov_wts(0:6,num_elems_2d)) + allocate(np_list_redist(num_elems_2d*5,20)) ! sizing is arbitrary !!! allocate data arrays allocate(data_elem(num_data)) @@ -70,49 +83,49 @@ subroutine fit_surface_geometry(niterations,fitting_file) data_elem = 0 !!! allocate dependent variable arrays - ny_max = 0 - do np = 1,num_nodes_2d - do nv = 1,node_versn_2d(np) - ny_max = ny_max+1 - enddo - enddo - ny_max = ny_max*num_nodes_2d*num_fit*num_deriv ! nodes * coordinates * #derivatives+1 + ny_max = sum(node_versn_2d(:))*num_nodes_2d*num_fit*num_deriv ! nodes * coordinates * #derivatives+1 allocate(nynr(0:ny_max)) - allocate(npny(0:6,ny_max)) + allocate(npny(1:6,ny_max)) allocate(nynp(num_deriv,nmax_versn,num_fit,num_nodes_2d)) allocate(fix_bcs(ny_max)) + write(*,'('' Define boundary conditions and mapping '')') + call define_geometry_fit(elem_list,np_list_redist,npny,num_depvar,nynp,nynr,nyny,& + cyny,sobelov_wts,fit_soln,fitting_file,fix_bcs) + call set_linear_derivatives + scale_factors_2d = 1.0_dp + !!! find the closest surface to each data point, and calculate the Xi !!! coordinates of the data point to the surface - write(*,'('' Calculating normal projections: slow first time '')') - call define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) + write(*,'('' Calculating normal projections (slow first time) for '',i8,'' data points'')') & + num_data + call define_xi_closest(data_elem,data_on_elem,elem_list,ndata_on_elem,data_xi,first) first = .false. !!! list the total error between the data points and the surface write(*,'(/'' TOTAL RMS ERROR PRIOR TO FITTING:'')') call list_data_error(data_on_elem,ndata_on_elem,data_xi) - !!! read 'fitting_file' to define the fitting constraints. set up mapping !!! arrays, dependent variable arrays, Sobelov smoothing weights (hardcoded) - write(*,'('' Define fitting problem '')') -! call define_geometry_fit(elem_list,npny,num_depvar,nynp,nynr,nyny,& -! cyny,sobelov_wts,fit_soln,fitting_file,fix_bcs) - do nfit = 1,niterations ! user-defined number of iterations - call define_geometry_fit(elem_list,npny,num_depvar,nynp,nynr,nyny,& - cyny,sobelov_wts,fit_soln,fitting_file,fix_bcs) write(*,'(/'' FITTING ITERATION'',I3)') nfit !!! solve for new nodal coordinates and derivatives write(*,'('' Solve fitting problem '')') call solve_geometry_fit(data_on_elem,ndata_on_elem,num_depvar,& - elem_list,not_1,not_2,npny,nynp,nynr,& + elem_list,not_1,not_2,npny,nynp,& nyny,data_xi,cyny,sobelov_wts,fit_soln,fix_bcs) + call update_versions(nynp,fit_soln,fix_bcs) + call calc_arclengths + write(*,'('' Update pseudo-landmarks locations '')') + ! update the node locations on base, fissures, anterior and posterior lines + call distribute_surface_node_fit(np_list_redist,nynp,fit_soln,fix_bcs) ! lateral-base + !!! update the scale factors for new geometry if NOT unit scale factors ! write(*,'('' Update scale factors '')') ! call update_scale_factor_norm !!! update the data point projections and their Xi coordinates write(*,'('' Calculating normal projections '')') - call define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) + call define_xi_closest(data_elem,data_on_elem,elem_list,ndata_on_elem,data_xi,first) !!! calculated the updated error between data and surface write(*,'(/'' CURRENT RMS ERROR FOR ALL DATA:'')') call list_data_error(data_on_elem,ndata_on_elem,data_xi) @@ -126,15 +139,18 @@ subroutine fit_surface_geometry(niterations,fitting_file) deallocate(cyny) deallocate(nynr) deallocate(npny) + deallocate(np_list_redist) deallocate(nynp) deallocate(nyny) deallocate(fix_bcs) + call enter_exit(sub_name,2) + end subroutine fit_surface_geometry !!! ########################################################################## - subroutine define_geometry_fit(elem_list,npny,num_depvar,nynp,nynr,nyny,& + subroutine define_geometry_fit(elem_list,np_list_redist,npny,num_depvar,nynp,nynr,nyny,& cyny,sobelov_wts,fit_soln,fitting_file,fix_bcs) !!! read information from 'fitting_file' to determine the boundary conditions @@ -142,19 +158,27 @@ subroutine define_geometry_fit(elem_list,npny,num_depvar,nynp,nynr,nyny,& !!! dependent variable-to-mapping arrays !!! dummy arguments - integer :: elem_list(0:),npny(0:,:),num_depvar,nynp(:,:,:,:),nynr(0:) + integer :: elem_list(:),np_list_redist(:,:),npny(:,:),num_depvar,nynp(:,:,:,:),nynr(0:) integer,allocatable :: nyny(:,:) real(dp) :: sobelov_wts(0:,:) real(dp),allocatable :: cyny(:,:),fit_soln(:,:,:,:) character(len=*),intent(in) :: fitting_file logical :: fix_bcs(:) !!! local variables - integer :: i,ibeg,iend,ierror,IPFILE=10,i_ss_end,L,ne,nh,nj,nk,node,np,& - np_global,number_of_fixed,nv,nv_fix,ny - character(len=132) :: readfile,string + integer :: i,ibeg,iend,ierror,IPFILE=10,i_ss_end,L,ne,nh,nj,nk, & + node,np,np_global,number_of_maps,number_of_fixed,num_redists,nv,nv_fix,ny + integer,allocatable :: nmap_info(:,:) + real(dp) :: temp_weights(7) + character(len=300) :: readfile,string,sub_string + character(len=60) :: sub_name + ! -------------------------------------------------------------------------- + + sub_name = 'define_geometry_fit' + call enter_exit(sub_name,1) if(.not.allocated(fit_soln)) allocate(fit_soln(4,10,16,num_nodes_2d)) + allocate(nmap_info(7,num_nodes_2d*num_deriv*nmax_versn)) ! linear fitting for 3 geometric variables. solution stored in fields 1,2,3 ! includes Sobelov smoothing on the geometry field @@ -162,93 +186,153 @@ subroutine define_geometry_fit(elem_list,npny,num_depvar,nynp,nynr,nyny,& !***Set up dependent variable interpolation information fit_soln = node_xyz_2d -!!! the following not correct because it refers to the global element #s -!!! use elem_list because we might want to fit only some of the elements -! elem_list(1:num_elems_2d) = elems_2d(1:num_elems_2d) - forall (i=1:num_elems_2d) elem_list(i) = i - elem_list(0) = num_elems_2d + elem_list = 0 - ! *** Specify smoothing constraints on each element - do L=1,elem_list(0) - ne=elem_list(L) - sobelov_wts(0,ne) = 1.0_dp - sobelov_wts(1,ne) = 1.0_dp !the scaling factor for the Sobolev weights - ! The 5 weights on derivs wrt Xi_1/_11/_2/_22/'_12 are: - sobelov_wts(2,ne) = 1.0e-4_dp !weight for deriv wrt Xi_1 - sobelov_wts(3,ne) = 2.0e-3_dp - sobelov_wts(4,ne) = 1.0e-4_dp - sobelov_wts(5,ne) = 2.0e-3_dp - sobelov_wts(6,ne) = 5.0e-3_dp - enddo !L - !*** Calculate ny maps - call calculate_ny_maps(npny,num_depvar,nynp,nynr) + call calculate_ny_maps(npny,num_depvar,nynp) fix_bcs = .false. !initialise, default - readfile = trim(fitting_file)//'.ipmap' + if(index(fitting_file, ".ipmap")> 0) then !full filename is given + readfile = fitting_file + else ! need to append the correct filename extension + readfile = trim(fitting_file)//'.ipmap' + endif open(IPFILE, file = readfile, status='old') - read_number_of_fixed : do - read(unit=IPFILE, fmt="(a)", iostat=ierror) string - if(index(string, "fixed")> 0) then - call get_final_integer(string,number_of_fixed) - exit read_number_of_fixed - endif - end do read_number_of_fixed - - do node = 1,number_of_fixed - read(unit=IPFILE, fmt="(a)", iostat=ierror) string - ibeg = 1 - i_ss_end = len(string) !get the end location of the sub-string - iend=index(string," ") !get location of next blank in sub-string - read (string(ibeg:iend-1), '(i6)' ) np_global - np = get_local_node_f(2,np_global) - string = adjustl(string(iend:i_ss_end)) ! get chars beyond " " and remove the leading blanks - iend=index(string," ") !get location of next blank in sub-string - read (string(ibeg:iend-1), '(i6)' ) nv_fix - - string = adjustl(string(iend:i_ss_end)) ! get chars beyond " " and remove the leading blanks - read (string(ibeg:i_ss_end), '(i6)' ) nk - -! string = adjustl(string(iend:i_ss_end)) ! get chars beyond " " and remove the leading blanks -! read (string(ibeg:i_ss_end), '(i6)' ) nk +!!! read the element list for fitting, the fixed node locations and/or derivatives, +!!! and the nodal derivative mapping for versions of nodes. Node locations for +!!! multiple versions are assumed to be mapped to version 1. + read(unit=IPFILE, fmt="(a)", iostat=ierror) string + if(index(string, "Elements in fit:")> 0) then + ibeg = index(string,":")+1 ! get location of first integer in string + iend = len(string) + sub_string = adjustl(string(ibeg:iend)) ! get the characters beyond ":" + read(sub_string, fmt=*, iostat=ierror) elem_list + endif - nk=nk+1 !read in 0 for coordinate, 1 for 1st deriv, 2 for 2nd deriv - if(nv_fix.eq.0)then ! do for all versions - do nv = 1,node_versn_2d(np) + read(unit=IPFILE, fmt="(a)", iostat=ierror) string + if(index(string, "Fixed nodes:")> 0) then + read_fixed_nodes : do + read(unit=IPFILE, fmt="(a)", iostat=ierror) string + if(index(string, "Mapped nodes:")> 0) exit ! move to the mapping + read(string, fmt=*, iostat=ierror) np_global, nv_fix, nk + np = get_local_node_f(2,np_global) + nk = nk+1 !read in 0 for coordinate, 1 for 1st deriv, 2 for 2nd deriv + if(nv_fix.eq.0)then ! do for all versions + do nv = 1,node_versn_2d(np) + do nh = 1,3 + ny = nynp(nk,nv,nh,np) + fix_bcs(ny) = .true. + enddo !nh + enddo !nv + else + nv = nv_fix do nh = 1,3 ny = nynp(nk,nv,nh,np) fix_bcs(ny) = .true. + !fit_soln(nk,nv,nh,np) = 0.0_dp ! shouldn't be zero enddo !nh - enddo !nv + endif + enddo read_fixed_nodes !node + endif + + number_of_maps = 0 + nmap_info = 0 + read_mapped_nodes : do + read(unit=IPFILE, fmt="(a)", iostat=ierror) string + if(index(string, "Redistribute nodes:")> 0) exit ! go to the enxt section + number_of_maps = number_of_maps + 1 + read(string, fmt=*, iostat=ierror) nmap_info(1:7,number_of_maps) + enddo read_mapped_nodes + + np_list_redist = 0 + num_redists = 0 + read_redistribute_nodes : do + read(unit=IPFILE, fmt="(a)", iostat=ierror) string + if(index(string, "Sobelov weights:")> 0) exit ! end of file + num_redists = num_redists + 1 + read(string, fmt=*, iostat=ierror) np_list_redist(num_redists,:) + enddo read_redistribute_nodes + + ! *** Specify smoothing constraints on each element + ! set some default values in case smoothing not specified + sobelov_wts(0,:) = 1.0_dp + sobelov_wts(1,:) = 1.0_dp !the scaling factor for the Sobolev weights + ! The 5 weights on derivs wrt Xi_1/_11/_2/_22/'_12 are: + sobelov_wts(2,:) = 1.0e-2_dp !weight for deriv wrt Xi_1 + sobelov_wts(3,:) = 0.4_dp + sobelov_wts(4,:) = 1.0e-2_dp + sobelov_wts(5,:) = 0.4_dp + sobelov_wts(6,:) = 0.8_dp + read_smoothing : do + read(unit=IPFILE, fmt="(a)", iostat=ierror) string + if(index(string, "End:")> 0) exit ! end of file + read(string, fmt=*, iostat=ierror) ne,temp_weights(1:7) + if(ne.eq.0)then + forall(i = 0:6) sobelov_wts(i,1:num_elems_2d) = temp_weights(i+1) else - nv = nv_fix - do nh = 1,3 - ny = nynp(nk,nv,nh,np) - fix_bcs(ny) = .true. - fit_soln(nk,nv,nh,np) = 0.0_dp - enddo !nh + ne = get_local_elem_2d(ne) + forall(i = 0:6) sobelov_wts(i,ne) = temp_weights(i+1) endif - enddo !node + enddo read_smoothing - call map_versions(IPFILE,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) + close(IPFILE) + + call map_versions(nmap_info,number_of_maps,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) ! fix ALL of the cross derivatives, and set to zero do np = 1,num_nodes_2d - nk = 4 !index for 1-2 cross-derivative do nv = 1,node_versn_2d(np) do nj = 1,num_coords - ny = nynp(nk,nv,nj,np) + ny = nynp(4,nv,nj,np) fix_bcs(ny) = .TRUE. node_xyz_2d(nk,nv,nj,np) = 0.0_dp enddo !nj enddo !nv enddo !np + deallocate(nmap_info) + + call enter_exit(sub_name,2) + end subroutine define_geometry_fit +!!! ########################################################################## + + subroutine initialise_fit_mesh() + !*initialise_fit_mesh:* scale and translate the mesh to align with a data + ! cloud. uses the centre of mass and the range of data coordinates. + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIALISE_FIT_MESH" :: INITIALISE_FIT_MESH + ! Local variables + integer :: i + real(dp) :: datacofm(3),meshcofm(3),datarange(3),meshrange(3), & + movemesh(3),scalemesh(3) + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'initialise_fit_mesh' + call enter_exit(sub_name,1) + + do i = 1,3 + datacofm(i) = sum(data_xyz(i,:))/real(num_data) + datarange(i) = maxval(data_xyz(i,:)) - minval(data_xyz(i,:)) + meshcofm(i) = sum(node_xyz_2d(1,1,i,:))/real(num_nodes_2d) + meshrange(i) = maxval(node_xyz_2d(1,1,i,:)) - minval(node_xyz_2d(1,1,i,:)) + enddo + + scalemesh = datarange/meshrange + movemesh = datacofm - meshcofm * scalemesh + + forall (i=1:3) node_xyz_2d(1,:,i,:) = node_xyz_2d(1,:,i,:) * & + scalemesh(i) + movemesh(i) + + call enter_exit(sub_name,2) + + end subroutine initialise_fit_mesh + !!! ########################################################################## subroutine gauss1(PG) @@ -258,6 +342,12 @@ subroutine gauss1(PG) !!! local variables integer :: I,J,ng,nk,nn,ns,nu real(dp) :: D(3),XI(3),XIGG(3,3,2) + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'gauss1' + call enter_exit(sub_name,1) D = [-0.3872983346207410_dp, 0.0_dp, 0.3872983346207410_dp] @@ -279,27 +369,9 @@ subroutine gauss1(PG) enddo !i enddo !j - end subroutine gauss1 - -!!! ########################################################################## + call enter_exit(sub_name,2) - function getnyr(npny,ny,nynp) - -!!! returns the dependent variable number -!!! dummy arguments - integer :: npny(0:,:),ny,nynp(:,:,:,:) -!!! local variables - integer :: nh,nk,np,nv - integer :: getnyr - - getnyr = 0 - nk = npny(1,ny) - nv = npny(2,ny) - nh = npny(3,ny) - np = npny(4,ny) - getnyr = nynp(nk,nv,nh,np) - - end function getnyr + end subroutine gauss1 !!! ########################################################################## @@ -308,13 +380,19 @@ subroutine globalf(nony,not_1,not_2,npny,nyno,nynp,nyny,cony,cyno,cyny,fix_bcs) !!! calculates the mapping arrays nyno/nony/cyno/cony !!! dummy arguments - integer :: nony(0:,:,:),not_1,not_2,npny(0:,:),nyno(0:,:,:),nynp(:,:,:,:),nyny(0:,:) - real(dp) :: cony(0:,:,:),cyno(0:,:,:),cyny(0:,:) + integer :: nony(0:,:),not_1,not_2,npny(:,:),nyno(0:,:,:),nynp(:,:,:,:),nyny(0:,:) + real(dp) :: cony(:),cyno(0:,:),cyny(0:,:) logical :: fix_bcs(:) !!! local variables - integer :: nh,nv,nk,no,no_tot(2),np,nrc,ny,nyy(2),nyo,nyr,nyr2,nyy2(2),ny2 - real(dp) :: COY,RATIO + integer :: nh,nv,nk,no,no_tot(2),np,nrc,ny,nyo,nyr,nyr2,nyy2(2),ny2 + real(dp) :: RATIO logical :: done + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'globalf' + call enter_exit(sub_name,1) !!!*** Initialise mapping arrays nony = 0 @@ -324,16 +402,14 @@ subroutine globalf(nony,not_1,not_2,npny,nyno,nynp,nyny,cony,cyno,cyny,fix_bcs) no_tot = 0 !!!*** Calculate mapping arrays - do np=1,num_nodes_2d - do nh=1,num_fit - do nv=1,node_versn_2d(np) - do nk=1,num_deriv - ny=nynp(nk,nv,nh,np) + do np = 1,num_nodes_2d + do nh = 1,num_fit + do nv = 1,node_versn_2d(np) + do nk = 1,num_deriv + ny = nynp(nk,nv,nh,np) if(.not.fix_bcs(ny)) then ! variable needs to be solved for done = .false. - nyy(1) = nynp(nk,nv,nh,np) !global row # - nyy(2) = ny !global variable # ny2 = ny !the default if(nyny(0,ny).ne.0) then ! a special mapping ny2 = nyny(1,ny) @@ -346,36 +422,30 @@ subroutine globalf(nony,not_1,not_2,npny,nyno,nynp,nyny,cony,cyno,cyny,fix_bcs) else if(fix_bcs(ny2)) then fix_bcs(ny) = .TRUE. else ! no mapping - nyy2(1) = getnyr(npny,ny2,nynp) !row# - nyy2(2) = ny2 !global col# - do nrc=1,2 !nrc=1,2 local row and local column - nyr = nyy(nrc) - nyr2 = nyy2(nrc) - nony(0,nyr,nrc) = 1 - no = nony(1,nyr2,nrc) - nony(1,nyr,nrc) = no - COY = RATIO*cony(1,nyr2,nrc) - cony(1,nyr,nrc) = COY -! write(*,*) np,nh,nv,nk,ny,ny2,nrc + do nrc = 1,1 ! nrc = 1,2 local row and local column + nyr = ny + nony(0,ny) = 1 + no = nony(1,ny2) + nony(1,ny) = no + cony(ny) = RATIO*cony(ny2) nyo = nyno(0,no,nrc)+1 nyno(0,no,nrc) = nyo - nyno(nyo,no,nrc) = nyr - cyno(nyo,no,nrc) = COY + nyno(nyo,no,nrc) = ny + cyno(nyo,no) = RATIO*cony(ny2) enddo !nrc endif !ny2=0/fix_bcs endif !ny.NE.ny2 if(.not.done) then - do nrc=1,2 !rows and columns + do nrc=1,1 !rows and columns no_tot(nrc) = no_tot(nrc)+1 - nony(0,nyy(nrc),nrc) = 1 - nony(1,nyy(nrc),nrc) = no_tot(nrc) - cony(0,nyy(nrc),nrc) = 0.0_dp - cony(1,nyy(nrc),nrc) = 1.0_dp + nony(0,ny) = 1 + nony(1,ny) = no_tot(nrc) + cony(ny) = 1.0_dp nyno(0,no_tot(nrc),nrc) = 1 - nyno(1,no_tot(nrc),nrc) = nyy(nrc) - cyno(0,no_tot(nrc),nrc) = 0.0_dp - cyno(1,no_tot(nrc),nrc) = 1.0_dp + nyno(1,no_tot(nrc),nrc) = ny + cyno(0,no_tot(nrc)) = 0.0_dp + cyno(1,no_tot(nrc)) = 1.0_dp enddo !nrc endif !not done endif !fix @@ -385,148 +455,12 @@ subroutine globalf(nony,not_1,not_2,npny,nyno,nynp,nyny,cony,cyno,cyny,fix_bcs) enddo !np NOT_1 = no_tot(1) - NOT_2 = no_tot(2) - - end subroutine globalf + NOT_2 = no_tot(1) + nyno(:,:,2) = nyno(:,:,1) -!!! ########################################################################## + call enter_exit(sub_name,2) - subroutine line_segments_for_2d_mesh - -!!! sets up the line segment arrays for a 2d mesh - -!!! local variables - integer :: ne,ne_adjacent,ni1,nj,npn(2) - logical :: MAKE - - num_lines_2d=0 - ! estimate number of lines, for allocating memory to arrays - do ne=1,num_elems_2d - if(elem_cnct_2d(-1,0,ne) == 0) num_lines_2d=num_lines_2d+1 - if(elem_cnct_2d(-2,0,ne) == 0) num_lines_2d=num_lines_2d+1 - num_lines_2d=num_lines_2d+2 ! the minimum # of new lines for each element - enddo - - if(.not.allocated(lines_2d)) allocate (lines_2d(0:num_lines_2d)) - if(.not.allocated(line_versn_2d)) allocate(line_versn_2d(2,3,num_lines_2d)) - if(.not.allocated(elem_lines_2d)) allocate (elem_lines_2d(4,num_elems_2d)) - if(.not.allocated(lines_in_elem)) allocate (lines_in_elem(0:4,num_lines_2d)) - if(.not.allocated(nodes_in_line)) allocate (nodes_in_line(3,0:3,num_lines_2d)) - if(.not.allocated(scale_factors_2d)) allocate(scale_factors_2d(16,num_elems_2d)) - if(.not.allocated(arclength)) allocate(arclength(3,num_lines_2d)) - - lines_in_elem=0 - lines_2d=0 - elem_lines_2d=0 - nodes_in_line=0 - line_versn_2d=0 - num_lines_2d=0 - - do ne=1,num_elems_2d - !check whether to make a line - MAKE=.FALSE. - if(elem_cnct_2d(-1,0,ne) == 0) MAKE=.TRUE. !exterior, make line - ne_adjacent=elem_cnct_2d(-1,1,ne) - if(ne_adjacent.gt.0)then - if(elem_lines_2d(4,ne_adjacent) == 0) MAKE=.TRUE. - endif - - if(MAKE)then - num_lines_2d=num_lines_2d+1 - lines_2d(num_lines_2d)=num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d)=lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d)=ne !line num_lines_2d is in element ne - elem_lines_2d(3,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 3 of ne - npn(1)=1 - npn(2)=3 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(1,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(3,ne) !records 2nd node in line - nodes_in_line(1,0,num_lines_2d)=2 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - else !get adjacent element line number - !WARNING:: this only works if all Xi directions are consistent!!!! - ne_adjacent=elem_cnct_2d(-1,1,ne) - elem_lines_2d(3,ne)=elem_lines_2d(4,ne_adjacent) - endif - - !check whether to make a line - MAKE=.FALSE. - if(elem_cnct_2d(-2,0,ne) == 0) MAKE=.TRUE. !exterior, make line - ne_adjacent=elem_cnct_2d(-2,1,ne) - if(ne_adjacent.gt.0)then - if(elem_lines_2d(2,ne_adjacent) == 0) MAKE=.TRUE. - endif - - if(MAKE)then - num_lines_2d=num_lines_2d+1 - lines_2d(num_lines_2d)=num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d)=lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d)=ne !line num_lines_2d is in element ne - elem_lines_2d(1,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 1 of ne - npn(1)=1 - npn(2)=2 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(1,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(2,ne) !records 2nd node in line - ! write(*,*) 'line in -2 for ne',ne,num_lines_2d,' nodes',npne(1,ne),npne(2,ne) - nodes_in_line(1,0,num_lines_2d)=1 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - else !get adjacent element line number - !WARNING:: this only works if all Xi directions are consistent!!!! - ne_adjacent=elem_cnct_2d(-2,1,ne) - elem_lines_2d(1,ne)=elem_lines_2d(2,ne_adjacent) - ! write(*,*) 'adjacent in -2',ne,ne_adjacent,elem_lines_2d(1,ne) - endif - - num_lines_2d=num_lines_2d+1 - lines_2d(num_lines_2d)=num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d)=lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d)=ne !line num_lines_2d is in element ne - elem_lines_2d(4,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 4 of ne - npn(1)=2 - npn(2)=4 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(2,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(4,ne) !records 2nd node in line - ! write(*,*) 'line in +2 for ne',ne,num_lines_2d,' nodes',npne(2,ne),npne(4,ne) - nodes_in_line(1,0,num_lines_2d)=2 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - - num_lines_2d = num_lines_2d+1 - lines_2d(num_lines_2d) = num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d) = lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d) = ne !line num_lines_2d is in element ne - elem_lines_2d(2,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 2 of ne - npn(1) = 3 - npn(2) = 4 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(3,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(4,ne) !records 2nd node in line - nodes_in_line(1,0,num_lines_2d)=1 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - - enddo !ne - - call calc_scale_factors_2d('arcl') - - end subroutine line_segments_for_2d_mesh + end subroutine globalf !!! ########################################################################## @@ -540,31 +474,37 @@ subroutine list_data_error(data_on_elem,ndata_on_elem,data_xi) real(dp) :: data_xi(:,:) !!! local variables integer elem,nd,nde,num_data_infit,ne,nj - real(dp) :: data_xi_local(2),EDD,SAED,SMED,SUM,SQED,X(6),& - XE(num_deriv_elem,num_coords) + real(dp) :: data_xi_local(2),EDD,elem_xyz(num_deriv_elem,num_coords), & + SAED,SMED,SUM,SQED,X(6) + + character(len=60) :: sub_name + ! -------------------------------------------------------------------------- + sub_name = 'list_data_error' + call enter_exit(sub_name,1) + SMED=0.0_dp SAED=0.0_dp SQED=0.0_dp num_data_infit=0 do ne=1,num_elems_2d - call xpxe(ne,xe) + call node_to_local_elem(ne,elem_xyz) elem=ne do nde=1,ndata_on_elem(elem) !for each data point on element nd=data_on_elem(elem,nde) !the data point number data_xi_local(1:2) = data_xi(1:2,nd) do nj=1,num_coords - X(nj)=PXI(1,data_xi_local,XE(1,nj)) + X(nj)=PXI(1,data_xi_local,elem_xyz(1,nj)) enddo SUM=0.0_dp do nj=1,num_coords SUM=SUM+(X(nj)-data_xyz(nj,nd))**2 enddo !nj - EDD=DSQRT(SUM) + EDD = sqrt(SUM) ! distance of the point from the surface SMED=SMED+EDD - SAED=SAED+DABS(EDD) + SAED=SAED+abs(EDD) SQED=SQED+EDD**2 num_data_infit=num_data_infit+1 enddo !nde @@ -572,28 +512,27 @@ subroutine list_data_error(data_on_elem,ndata_on_elem,data_xi) if(num_data_infit.GT.1) then write(*,'('' Number of data points in fit ='',I8)') num_data_infit - ! write(*,'('' Average error : '',D12.6,'' +/- '',D12.6)') & - ! SMED/DBLE(num_data_infit), & - ! DSQRT((SQED-SMED**2/DBLE(num_data_infit))/DBLE(num_data_infit-1)) - write(*,'('' Average absolute error : '',D12.6,'' +/- '',D12.6)') & - SAED/DBLE(num_data_infit),DSQRT((SQED-SAED**2/DBLE(num_data_infit))/ & - DBLE(num_data_infit-1)) + SAED/real(num_data_infit),sqrt((SQED-SAED**2/real(num_data_infit))/ & + real(num_data_infit-1)) write(*,'('' Root mean squared error : '',D12.6)') & - DSQRT(SQED/DBLE(num_data_infit)) + sqrt(SQED/DBLE(num_data_infit)) else WRITE(*,'('' No data points in any elements'')') stop endif !ndtot>1 + call enter_exit(sub_name,2) + end subroutine list_data_error !!! ########################################################################## - subroutine map_versions(IPFILE,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) + subroutine map_versions(nmap_info,number_of_maps,num_depvar,nynp,nyny, & + cyny,fit_soln,fix_bcs) !!! dummy arguments - integer, intent(in) :: IPFILE,num_depvar + integer, intent(in) :: nmap_info(:,:),num_depvar integer :: nynp(:,:,:,:) integer,allocatable :: nyny(:,:) real(dp),allocatable :: cyny(:,:) @@ -602,17 +541,22 @@ subroutine map_versions(IPFILE,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) !!! local variables integer :: i,ibeg,iend,ierror,i_ss_end,nj,node,np,number_of_maps,nv, & NV_MAX,ny,nk_t,nv_t,nj_t,np_t,nk_m,nv_m,nj_m,np_m, & - nmap_info(100,7),ny_t + ny_t real(dp) :: r_map_coef character(len=132) :: string + character(len=60) :: sub_name + ! -------------------------------------------------------------------------- + + sub_name = 'map_versions' + call enter_exit(sub_name,1) + !!! fix the boundary conditions for coordinates for nodes with versions, such that !!! versions higher than 1 map to version 1 - do np=1,num_nodes_2d - NV_MAX=node_versn_2d(np) - if(NV_MAX>1)then - do nv=2,NV_MAX - do nj=1,num_coords + do np = 1,num_nodes_2d + if(node_versn_2d(np).gt.1)then + do nv = 2,node_versn_2d(np) + do nj = 1,num_coords node_xyz_2d(1,nv,nj,np) = node_xyz_2d(1,1,nj,np) fit_soln(1,nv,nj,np) = fit_soln(1,1,nj,np) ny = nynp(1,nv,nj,np) @@ -624,19 +568,8 @@ subroutine map_versions(IPFILE,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) !!! read in the following for mapping: !!! node, version, derivative >> node, version, derivative, mapping coefficient -!!! default is that all versions are independent - - read_number_of_mappings : do - read(unit=IPFILE, fmt="(a)", iostat=ierror) string - ! read line containing "Number of mappings" - if(index(string, "mappings")> 0) then - call get_final_integer(string,number_of_maps) - exit read_number_of_mappings - endif - end do read_number_of_mappings - + ! allocate memory for dependent variable mapping arrays - write(*,*) 'Number of dependent variables =',num_depvar,'; squared =',num_depvar**2 if(.not.allocated(cyny)) allocate(cyny(0:number_of_maps,num_depvar)) if(.not.allocated(nyny)) allocate(nyny(0:number_of_maps,num_depvar)) nyny = 0 ! initialise depvar to depvar mapping @@ -644,40 +577,27 @@ subroutine map_versions(IPFILE,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) !!! note that the global node numbers are used in the mapping file, whereas we need to use !!! local numbering for the computation. Read in as global and then map to local below. - do node=1,number_of_maps ! for the number of nodes with mappings - read(unit=IPFILE, fmt="(a)", iostat=ierror) string - ibeg=1 - i_ss_end=len(string) !get the end location of the sub-string - do i=1,6 - iend=index(string," ") !get location of next blank in sub-string - read (string(ibeg:iend-1), '(i6)' ) nmap_info(node,i) - string = adjustl(string(iend:i_ss_end)) ! get the characters beyond " " and remove the leading blanks - enddo !i - read (string(ibeg:i_ss_end), '(i6)' ) nmap_info(node,7) - enddo !node - - do node = 1,number_of_maps !for each mapping + do node = 1,number_of_maps ! for the number of nodes with mappings do nj = 1,num_coords - nk_m = nmap_info(node,3)+1 !derivative - nv_m = nmap_info(node,2) !version + nk_m = nmap_info(3,node)+1 !derivative + nv_m = nmap_info(2,node) !version nj_m = nj !coordinate - np_m = get_local_node_f(2,nmap_info(node,1)) !global node mapped to local node + np_m = get_local_node_f(2,nmap_info(1,node)) !global node mapped to local node ny = nynp(nk_m,nv_m,nj_m,np_m) - nk_t = nmap_info(node,6)+1 !derivative - nv_t = nmap_info(node,5) !version + nk_t = nmap_info(6,node)+1 !derivative + nv_t = nmap_info(5,node) !version nj_t = nj !coordinate - np_t = get_local_node_f(2,nmap_info(node,4)) !global node mapped to local node + np_t = get_local_node_f(2,nmap_info(4,node)) !global node mapped to local node ny_t = nynp(nk_t,nv_t,nj_t,np_t) - r_map_coef = REAL(nmap_info(node,7)) !mapping coefficient, +1 or -1 + r_map_coef = REAL(nmap_info(7,node)) !mapping coefficient, +1 or -1 - if(ny > 0) then + if(ny.gt.0) then nyny(0,ny) = nyny(0,ny)+1 ! increment array size nyny(nyny(0,ny),ny) = ny_t cyny(0,ny) = 0.0_dp cyny(nyny(0,ny),ny) = r_map_coef node_xyz_2d(nk_m,nv_m,nj_m,np_m) = node_xyz_2d(nk_t,nv_t,nj_t,np_t)*r_map_coef fit_soln(nk_m,nv_m,nj_m,np_m) = node_xyz_2d(nk_t,nv_t,nj_t,np_t)*r_map_coef -! write(*,*) 'mapping ny',ny_t,' to',ny,' with',r_map_coef endif ! ny.GT.0 enddo !nj enddo @@ -699,39 +619,440 @@ subroutine map_versions(IPFILE,num_depvar,nynp,nyny,cyny,fit_soln,fix_bcs) enddo !nv enddo !nj enddo - + + call enter_exit(sub_name,2) + end subroutine map_versions -!!! ########################################################################## +!!! ########################################################################## + + subroutine update_versions(nynp,fit_soln,fix_bcs) - subroutine melgef(LGE2,ne,NHST,nynp) + integer :: nynp(:,:,:,:) + real(dp) :: fit_soln(:,:,:,:) + logical :: fix_bcs(:) + ! Local variables + integer :: nj,nk,np,nv,ny + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- -!!! calculates the row numbers (LGE(*,1)) and column numbers -!!! (LGE(*,2)) in the matrix for fitting for element variables nhs -!!! and fit variable njj in region nr. It also returns the total -!!! number of element variables NHST(nrc). + sub_name = 'update_versions' + call enter_exit(sub_name,1) -!!! dummy arguments - integer :: LGE2(num_fit*num_deriv_elem,2),ne,NHST(2),nynp(:,:,:,:) +!!! fix the boundary conditions for coordinates for nodes with versions, such that +!!! versions higher than 1 map to version 1 + do np = 1,num_nodes_2d + if(node_versn_2d(np) > 1)then + do nv = 2,node_versn_2d(np) + do nj = 1,3 + node_xyz_2d(1,nv,nj,np) = node_xyz_2d(1,1,nj,np) + fit_soln(1,nv,nj,np) = fit_soln(1,1,nj,np) + ny = nynp(1,nv,nj,np) + fix_bcs(ny) = .TRUE. + enddo !nj + enddo !nv + endif + enddo !node + +!!! fix ALL of the cross derivatives, and set to zero + do np = 1,num_nodes_2d + nk = 4 !index for 1-2 cross-derivative + do nv = 1,node_versn_2d(np) + do nj = 1,3 + ny = nynp(nk,nv,nj,np) + fix_bcs(ny) = .TRUE. + node_xyz_2d(nk,nv,nj,np) = 0.0_dp + enddo !nj + enddo !nv + enddo !np + + call enter_exit(sub_name,2) + + end subroutine update_versions + +!!! ########################################################################## + + subroutine local_dof(n_dof,ne,ny_local,nynp) + + integer :: ny_local(:),n_dof,ne,nynp(:,:,:,:) !!! local variables - integer nh,nk,nn,np,nrc,nv - - do nrc=1,2 - NHST(nrc)=0 - do nh=1,num_fit - do nn=1,num_elem_nodes !nodal variables - np=elem_nodes_2d(nn,ne) - nv=elem_versn_2d(nn,ne) - do nk=1,num_deriv - NHST(nrc)=NHST(nrc)+1 - LGE2(NHST(nrc),nrc)=nynp(nk,nv,nh,np) - enddo !nk - enddo !nn - enddo !nhj - enddo !nrc + integer nh,nk,nn,np,nv + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'local_dof' + call enter_exit(sub_name,1) + + n_dof = 0 + do nh = 1,num_fit + do nn = 1,num_elem_nodes !nodal variables + np = elem_nodes_2d(nn,ne) + nv = elem_versn_2d(nn,ne) + do nk = 1,num_deriv + n_dof = n_dof + 1 + ny_local(n_dof) = nynp(nk,nv,nh,np) + enddo !nk + enddo !nn + enddo !nhj + + call enter_exit(sub_name,2) + + end subroutine local_dof + +!!! ########################################################################## + + subroutine distribute_surface_node_fit(np_list,nynp,fit_soln,fix_bcs) + + integer,intent(in) :: np_list(:,:),nynp(:,:,:,:) + real(dp) :: fit_soln(:,:,:,:) + logical,intent(in) :: fix_bcs(:) + ! Local variables + integer :: i,in_line,iredist,j,k,line_numbers(20),ne,nline,nlist,nn(4),node_2,np, & + np1,np2,np_between(20),np_end,np_start,num_lines,nv,nv1,nv2,n_xi_dctn,ny + real(dp) :: new_length,new_xyz(20,3),segment_length,sum_length,xi + + iredist = 1 + distribute_line : do + if(np_list(iredist,1).eq.0) exit distribute_line ! no more lines to distribute + np_start = get_local_node_f(2,np_list(iredist,1)) + + ! get the start and end nodes, and between nodes + np_between = 0 + i = 1 + get_line_nodes : do + i = i+1 + if(np_list(iredist,i).eq.0) exit get_line_nodes + np_between(i-1) = get_local_node_f(2,np_list(iredist,i)) + enddo get_line_nodes + nlist = i-2 + np_end = np_between(i-2) + + ! find the first element that has np_start and np_between(1) + find_element : do i = 1,elems_at_node_2d(np_start,0) + ne = elems_at_node_2d(np_start,i) + if(inlist(np_between(1),elem_nodes_2d(1:4,ne))) exit find_element + enddo find_element + + ! get the list of line segments + num_lines = 0 + segment_length = 0.0_dp + + do i = 1,nlist + np = np_between(i) ! the next 'between' node + do j = 1,num_lines_2d + nline = lines_2d(j) + if((np_start.eq.nodes_in_line(2,1,nline).and.np.eq.nodes_in_line(3,1,nline)).or.& + (np_start.eq.nodes_in_line(3,1,nline).and.np.eq.nodes_in_line(2,1,nline)))then + num_lines = num_lines + 1 + line_numbers(num_lines) = nline + segment_length = segment_length + arclength(nline) + endif + enddo + np_start = np + enddo ! i + segment_length = segment_length/real(num_lines) + + ! redistribute along the line segments + do i = 1,nlist-1 + node_2 = np_between(i) + nline = line_numbers(i) + new_length = segment_length*real(i) + sum_length = 0.0_dp + check_lines: do j = 1,num_lines ! check each line segment + if(new_length.gt.sum_length.and.new_length.le. & + sum_length+arclength(line_numbers(j)))then + ! in this segment + in_line = line_numbers(j) + np1 = nodes_in_line(2,1,in_line) + np2 = nodes_in_line(3,1,in_line) + nv1 = line_versn_2d(1,1,in_line) + nv2 = line_versn_2d(2,1,in_line) + n_xi_dctn = nodes_in_line(1,0,nline) + if(i.gt.1.and.(np1.ne.nodes_in_line(3,1,line_numbers(j-1))))then + xi = 1.0_dp - (new_length-sum_length)/arclength(line_numbers(j)) + else + xi = (new_length-sum_length)/arclength(line_numbers(j)) + endif + exit check_lines + else + sum_length = sum_length+arclength(line_numbers(j)) + endif + enddo check_lines + + ! x(xi) = phi_10*x1 + phi_20*x2 + phi_11*x1' + phi_21*x2' + new_xyz(i,:) = hermite(1,1,1,xi)*node_xyz_2d(1,nv1,:,np1) + & + hermite(2,1,1,xi)*node_xyz_2d(1,nv2,:,np2) + & + hermite(1,2,1,xi)*node_xyz_2d(n_xi_dctn+1,nv1,:,np1) + & + hermite(2,2,1,xi)*node_xyz_2d(n_xi_dctn+1,nv2,:,np2) + enddo ! i + + ! update the node coordinates + do i = 1,num_lines-1 + node_2 = np_between(i) + node_xyz_2d(1,1,:,node_2) = new_xyz(i,:) + do nv = 1,node_versn_2d(np) + do j = 1,3 + node_xyz_2d(1,nv,j,node_2) = node_xyz_2d(1,1,j,node_2) + ny = nynp(1,nv,j,node_2) + !if(fix_bcs(ny)) fit_soln(1,nv,j,node_2) = node_xyz_2d(1,nv,j,node_2) + fit_soln(1,nv,j,node_2) = node_xyz_2d(1,nv,j,node_2) + enddo ! j + enddo ! nv + enddo + + iredist = iredist + 1 + + enddo distribute_line + call calc_arclengths + + end subroutine distribute_surface_node_fit + +!!! ########################################################################## + + subroutine distribute_nodes_between(gnode_1,gnode_2,n_xi_dctn) + !*distribute_nodes_between*: update the location of all nodes on the line + ! in the n_xi_dctn direction between node_1 and node_2, so that they are + ! uniformly spread out wrt arclength. + + integer,intent(in) :: gnode_1,gnode_2,n_xi_dctn + ! Local variables + integer :: count_checks,i,in_line,j,ne_check,nline,nn,node_1,node_2,np1,np2, & + nthline,num_lines,nv1,nv2 + integer,allocatable :: line_numbers(:) + real(dp) :: new_length,new_xyz(100,3),segment_length,sum_length, & + total_length,xi + logical :: carry_on + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'distribute_nodes_between' + call enter_exit(sub_name,1) + + allocate(line_numbers(num_lines_2d)) + line_numbers = 0 + num_lines = 0 + count_checks = 0 + carry_on = .true. + + node_1 = get_local_node_f(2,gnode_1) + node_2 = get_local_node_f(2,gnode_2) + + if(elems_at_node_2d(node_1,0).eq.0.or.elems_at_node_2d(node_2,0).eq.0) & + ! one or both of the nodes is not in an element + carry_on = .false. + + ! get a list of all nodes that are on the line between node_1 and node_2 + if(carry_on)then + ne_check = elems_at_node_2d(node_1,1) + do i = 1,4 + if(node_1.eq.elem_nodes_2d(i,ne_check)) nn = i + enddo + if(nn.eq.1.and.n_xi_dctn.eq.1)then + nthline = 1 + num_lines = num_lines + 1 + line_numbers(num_lines) = elem_lines_2d(nthline,ne_check) + else if(nn.eq.1.and.n_xi_dctn.eq.2)then + nthline = 3 + num_lines = num_lines + 1 + line_numbers(num_lines) = elem_lines_2d(nthline,ne_check) + else if(nn.eq.2.and.n_xi_dctn.eq.1)then + nthline = 1 + else if(nn.eq.2.and.n_xi_dctn.eq.2)then + nthline = 4 + num_lines = num_lines + 1 + line_numbers(num_lines) = elem_lines_2d(nthline,ne_check) + else if(nn.eq.3.and.n_xi_dctn.eq.1)then + nthline = 2 + num_lines = num_lines + 1 + line_numbers(num_lines) = elem_lines_2d(nthline,ne_check) + else if(nn.eq.3.and.n_xi_dctn.eq.2)then + nthline = 3 + else if(nn.eq.4.and.n_xi_dctn.eq.1)then + nthline = 2 + else if(nn.eq.4.and.n_xi_dctn.eq.2)then + nthline = 4 + endif + + if(num_lines.eq.1)then ! check that we don't just have one line! + nline = line_numbers(num_lines) + if(nodes_in_line(3,1,nline).eq.node_2) carry_on = .false. + endif + + ne_check = elem_cnct_2d(n_xi_dctn,1,ne_check) + + do while(carry_on) + nline = elem_lines_2d(nthline,ne_check) + if(nodes_in_line(3,1,nline).eq.node_2)then + num_lines = num_lines + 1 + line_numbers(num_lines) = elem_lines_2d(nthline,ne_check) + carry_on = .false. + else + ! for collapsed elements, go to the next one + do while (nodes_in_line(2,1,nline).eq.nodes_in_line(3,1,nline)) + ne_check = elem_cnct_2d(n_xi_dctn,1,ne_check) + nline = elem_lines_2d(nthline,ne_check) + enddo + num_lines = num_lines + 1 + line_numbers(num_lines) = elem_lines_2d(nthline,ne_check) + count_checks = count_checks + 1 + if(count_checks.gt.num_elems_2d) carry_on = .false. + ne_check = elem_cnct_2d(n_xi_dctn,1,ne_check) + endif + enddo ! while + endif + + total_length = 0.0_dp + do i = 1,num_lines + nline = line_numbers(i) + total_length = total_length + arclength(nline) + enddo ! nline + segment_length = total_length/real(num_lines) + + do i = 1,num_lines-1 + nline = line_numbers(i) + node_2 = nodes_in_line(3,1,nline) + new_length = segment_length*real(i) + sum_length = 0.0_dp + check_lines: do j = 1,num_lines ! check each line segment + if(new_length.gt.sum_length.and.new_length.le. & + sum_length+arclength(line_numbers(j)))then + ! in this segment + in_line = line_numbers(j) + xi = (new_length-sum_length)/arclength(line_numbers(j)) + np1 = nodes_in_line(2,1,in_line) + np2 = nodes_in_line(3,1,in_line) + nv1 = line_versn_2d(1,1,in_line) + nv2 = line_versn_2d(2,1,in_line) + exit check_lines + else + sum_length = sum_length+arclength(line_numbers(j)) + endif + enddo check_lines + + ! x(xi) = phi_10*x1 + phi_20*x2 + phi_11*x1' + phi_21*x2' + new_xyz(i,:) = hermite(1,1,1,xi)*node_xyz_2d(1,nv1,:,np1) + & + hermite(2,1,1,xi)*node_xyz_2d(1,nv2,:,np2) + & + hermite(1,2,1,xi)*node_xyz_2d(n_xi_dctn+1,nv1,:,np1) + & + hermite(2,2,1,xi)*node_xyz_2d(n_xi_dctn+1,nv2,:,np2) + + enddo + + do i = 1,num_lines-1 + nline = line_numbers(i) + node_2 = nodes_in_line(3,1,nline) + node_xyz_2d(1,1,:,node_2) = new_xyz(i,:) + forall (j=1:6) node_xyz_2d(1,j,:,node_2) = node_xyz_2d(1,1,:,node_2) + enddo + + deallocate(line_numbers) + + call enter_exit(sub_name,2) - end subroutine melgef + end subroutine distribute_nodes_between +!!! ########################################################################## + + subroutine centre_a_node(update_node,n_xi_dctn) + !*centre_a_node*: updates the coordinates of the given node so that it sits + ! at xi between the two adjacent nodes in the n_xi_dctn direction + + integer,intent(in) :: n_xi_dctn,update_node + ! Local variables + integer :: i,iline_1,iline_2,nj,nline,np,np1,np2,nv,nv1,nv2 + real(dp) :: line_length,line_xyz(2,3,2),location = 0.5_dp, new_xyz(3),xi_on_line + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'centre_a_node' + call enter_exit(sub_name,1) + + np = get_local_node_f(2,update_node) + line_length = 0.0_dp + + do i = 1,num_lines_2d + nline = lines_2d(i) + if(nodes_in_line(1,0,nline).eq.n_xi_dctn)then ! only check lines in the right Xi direction + if(nodes_in_line(3,1,nline).eq.np.or. & + nodes_in_line(2,1,nline).eq.np)then + line_length = line_length + arclength(i) ! calculated the total arclength + if(nodes_in_line(3,1,nline).eq.np) iline_1 = i ! np is the second node + if(nodes_in_line(2,1,nline).eq.np) iline_2 = i + endif + endif + enddo + + line_length = line_length * location ! get the arclength for the adjusted node + if(line_length.le.arclength(iline_1))then + xi_on_line = line_length/arclength(iline_1) + nline = iline_1 + else + xi_on_line = (arclength(iline_2)-line_length)/arclength(iline_2) + nline = iline_2 + endif + + np1 = nodes_in_line(2,1,iline_1) + np2 = nodes_in_line(3,1,iline_1) + nv1 = line_versn_2d(1,1,iline_1) + nv2 = line_versn_2d(2,1,iline_1) + line_xyz(1,:,1) = node_xyz_2d(1,1,:,np1) + line_xyz(1,:,2) = node_xyz_2d(1,1,:,np2) + line_xyz(2,:,1) = node_xyz_2d(n_xi_dctn+1,nv1,:,np1) + line_xyz(2,:,2) = node_xyz_2d(n_xi_dctn+1,nv2,:,np2) + + ! x(xi) = phi_10*x1 + phi_20*x2 + phi_11*x1' + phi_21*x2' + new_xyz(:) = hermite(1,1,1,xi_on_line)*line_xyz(1,:,1) + & + hermite(2,1,1,xi_on_line)*line_xyz(1,:,2) + & + hermite(1,2,1,xi_on_line)*line_xyz(2,:,1) + & + hermite(2,2,1,xi_on_line)*line_xyz(2,:,2) + + do nv = 1,node_versn_2d(np) + node_xyz_2d(1,nv,:,np) = new_xyz(:) + enddo + write(*,'(''Node adjusted = '',3(f9.2))') node_xyz_2d(1,1,:,np) + + call enter_exit(sub_name,2) + + end subroutine centre_a_node + +!!! ########################################################################## + + subroutine set_linear_derivatives + + ! Local variables + integer :: ne,nk,nl,nline,np1,np2,nv1,nv2 + + do ne = 1,num_elems_2d + np1 = elem_nodes_2d(1,ne) + nv1 = elem_versn_2d(1,ne) + np2 = elem_nodes_2d(2,ne) + nv2 = elem_versn_2d(2,ne) + node_xyz_2d(2,nv1,:,np1) = node_xyz_2d(1,1,:,np2) & + - node_xyz_2d(1,1,:,np1) + + np2 = elem_nodes_2d(3,ne) + nv2 = elem_versn_2d(3,ne) + node_xyz_2d(3,nv1,:,np1) = node_xyz_2d(1,1,:,np2) & + - node_xyz_2d(1,1,:,np1) + + np1 = elem_nodes_2d(2,ne) + nv1 = elem_versn_2d(2,ne) + np2 = elem_nodes_2d(4,ne) + nv2 = elem_versn_2d(4,ne) + node_xyz_2d(3,nv1,:,np1) = node_xyz_2d(1,1,:,np2) & + - node_xyz_2d(1,1,:,np1) + + np1 = elem_nodes_2d(3,ne) + nv1 = elem_versn_2d(3,ne) + node_xyz_2d(2,nv1,:,np1) = node_xyz_2d(1,1,:,np2) & + - node_xyz_2d(1,1,:,np1) + enddo !ne + + end subroutine set_linear_derivatives + !!! ########################################################################## function psi1(nu,nk,nn,XI) @@ -749,7 +1070,7 @@ function psi1(nu,nk,nn,XI) psi1 = 1.0_dp do ni=1,2 - psi1 = psi1*ph3(inp(nn,ni),ido(nk,ni),ipu(nu,ni),xi(ni)) + psi1 = psi1*hermite(inp(nn,ni),ido(nk,ni),ipu(nu,ni),xi(ni)) enddo end function psi1 @@ -783,6 +1104,12 @@ subroutine update_scale_factor_norm !!! local variables integer :: nj,nk,nk1,np,nv real(dp) :: SCALE,XD(3),ZERO_TOL=1.0e-12_dp + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'update_scale_factor_norm' + call enter_exit(sub_name,1) do np=1,num_nodes_2d do nv=1,node_versn_2d(np) @@ -805,20 +1132,24 @@ subroutine update_scale_factor_norm call calc_scale_factors_2d('arcl') + call enter_exit(sub_name,2) + end subroutine update_scale_factor_norm !!! ########################################################################## - subroutine xpxe(ne,xe) + subroutine node_to_local_elem(ne,elem_xyz) !!! copies geometry information from nodes into a local element array !!! dummy arguments integer,intent(in) :: ne - real(dp) :: xe(:,:) + real(dp) :: elem_xyz(:,:) !!! local variablesK Local Variables integer :: nj,nk,nn,np,ns,nv + ! -------------------------------------------------------------------------- + do nj=1,3 ns=0 do nn=1,num_elem_nodes @@ -826,30 +1157,69 @@ subroutine xpxe(ne,xe) nv=elem_versn_2d(nn,ne) do nk=1,num_deriv ns=ns+1 - xe(ns,nj)=node_xyz_2d(nk,nv,nj,np)*scale_factors_2d(ns,ne) + elem_xyz(ns,nj)=node_xyz_2d(nk,nv,nj,np)*scale_factors_2d(ns,ne) enddo enddo enddo !nj - end subroutine xpxe + end subroutine node_to_local_elem !!! ########################################################################## - - subroutine zder(data_on_elem,ndata_on_elem,ne,data_xi,ER,PG,WDL,WG,sobelov_wts,& - XIDL,fit_soln_local) - + + subroutine make_element_matrices(ne,fit_soln_local,fit_soln, & + data_on_elem,ndata_on_elem,data_xi,ER,ES,sobelov_wts) + !!! Evaluates element rhs, ER(ns), in calculation of least squares !!! fit of linear field variables, defined by nodal values !!! node_xyz_2d(nk,nv,nj,np), to the set of data values data_xyz(nj,nd) with !!! weights data_weight(nj,nd) at local coordinate values data_xi(ni,nd). +!!! ZDES evaluates element stiffness matrix ES(ms,ns) in calculation +!!! of least squares fit of linear field variables, defined by nodal +!!! values node_xyz_2d(nk,nv,nj,np), to the set of data values XD(nj,nd) with +!!! weights data_weight(nj,nd) at local coordinate values data_xi(ni,nd), where +!!! nj=NJO. + !!! dummy arguments integer :: data_on_elem(:,:),ndata_on_elem(:),ne - real(dp) :: data_xi(:,:),ER(:),PG(:,:,:),WDL(:,:),WG(:),sobelov_wts(0:,:),& - XIDL(:,:),fit_soln_local(:,:) + real(dp) :: data_xi(:,:),ER(:),ES(:,:),sobelov_wts(0:,:),& + fit_soln(:,:,:,:),fit_soln_local(:,:) !!! local variables - integer nd,nde,ng,nh,nhs1,nk1,nn1,ns1,ns2,nu + integer nd,nde,ng,nh,nh1,nh2,nhj1,nhj2,nhs1,nhs1_for_nhj1,nhs2,nk,nk1,nk2, & + nn,nn1,nn2,np,ns,ns1,ns2,nu,nv real(dp) :: SUM1,SUM2,SUM3,SUM4,X,ZDL(3,nmax_data_elem) + real(dp) :: PD(num_deriv_elem),PG(16,6,9),WG(9) + real(dp),dimension(3,nmax_data_elem) :: WDL + real(dp),dimension(2,nmax_data_elem) :: XIDL + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'make_element_matrices' + call enter_exit(sub_name,1) + + WG = [7.7160493827160628e-2_dp, 0.12345679012345677_dp, 7.7160493827160628e-2_dp,& + 0.12345679012345677_dp, 0.19753086419753044_dp, 0.12345679012345677_dp,& + 7.7160493827160628e-2_dp, 0.12345679012345677_dp, 7.7160493827160628e-2_dp] + + ER = 0.0_dp + ES = 0.0_dp + + call gauss1(PG) + + do nh = 1,num_fit + ns = 0 + do nn = 1,num_elem_nodes + np = elem_nodes_2d(nn,ne) + nv = elem_versn_2d(nn,ne) + do nk = 1,num_deriv + ns = ns+1 + fit_soln_local(ns,nh) = fit_soln(nk,nv,nh,np)*scale_factors_2d(ns,ne) + enddo !nk + enddo !nn + enddo !nhx + +!!! evaluate the element matrix ER do nde = 1,ndata_on_elem(ne) ! for each data point on the element nd = data_on_elem(ne,nde) ! the data point number @@ -871,7 +1241,7 @@ subroutine zder(data_on_elem,ndata_on_elem,ne,data_xi,ER,PG,WDL,WG,sobelov_wts,& ns1 = ns1+1 SUM1 = 0.0_dp do nde = 1,ndata_on_elem(ne) - SUM1 = SUM1+PSI1(1,nk1,nn1,XIDL(1:2,nde))*ZDL(nh,nde)*WDL(nh,nde) + SUM1 = SUM1 + PSI1(1,nk1,nn1,XIDL(1:2,nde))*ZDL(nh,nde)*WDL(nh,nde) enddo !nde SUM2 = 0.0_dp do ng = 1,num_gauss @@ -890,52 +1260,34 @@ subroutine zder(data_on_elem,ndata_on_elem,ne,data_xi,ER,PG,WDL,WG,sobelov_wts,& enddo !nn1 enddo !nhj1 - end subroutine zder - -!!! ########################################################################## - - subroutine zdes(ndata_on_elem,ne,ES,PG,WDL,WG,sobelov_wts,XIDL) - -!!! ZDES evaluates element stiffness matrix ES(ms,ns) in calculation -!!! of least squares fit of linear field variables, defined by nodal -!!! values node_xyz_2d(nk,nv,nj,np), to the set of data values XD(nj,nd) with -!!! weights data_weight(nj,nd) at local coordinate values data_xi(ni,nd), where -!!! nj=NJO. - -!!! dummy arguments - integer :: ndata_on_elem(:),ne - real(dp) :: ES(:,:),PG(:,:,:),WDL(:,:),WG(:),sobelov_wts(0:,:),XIDL(:,:) -!!! local variables - integer nde,ng,nh1,nh2,nhj1,nhj2,nhs1,nhs1_for_nhj1,nhs2, & - nk1,nk2,nn1,nn2,ns1,ns2,nu - real(dp) :: PD(num_deriv_elem),SUM2,SUM3 +!!! evaluate the element matrix ES ES = 0.0_dp nhs1 = 0 - ! for each of the 3 dependent variables to be fitted (num_fit(1)=3) - do nhj1=1,num_fit !nhj are vars for the fit problem njj - nh1=nhj1 + ! for each of the 3 dependent variables to be fitted + do nhj1 = 1,num_fit !nhj are vars for the fit problem njj + nh1 = nhj1 nhs1_for_nhj1 = nhs1 - do nde=1,ndata_on_elem(ne) + do nde = 1,ndata_on_elem(ne) nhs1 = nhs1_for_nhj1 - ns1=0 - do nn1=1,num_elem_nodes - do nk1=1,num_deriv - nhs1=nhs1+1 - ns1=ns1+1 - PD(ns1)=PSI1(1,nk1,nn1,XIDL(1:2,nde)) + ns1 = 0 + do nn1 = 1,num_elem_nodes + do nk1 = 1,num_deriv + nhs1 = nhs1+1 + ns1 = ns1+1 + PD(ns1) = PSI1(1,nk1,nn1,XIDL(1:2,nde)) enddo !nk1 enddo !nn1 nhs1 = nhs1_for_nhj1 - do ns1=1,num_deriv_elem - nhs1=nhs1+1 - nhs2=0 - do nhj2=1,num_fit !columns - nh2=nhj2 - do ns2=1,num_deriv_elem - nhs2=nhs2+1 + do ns1 = 1,num_deriv_elem + nhs1 = nhs1+1 + nhs2 = 0 + do nhj2 = 1,num_fit !columns + nh2 = nhj2 + do ns2 = 1,num_deriv_elem + nhs2 = nhs2+1 if(nhj2.EQ.nhj1) then !to avoid coupling for now - ES(nhs1,nhs2)=ES(nhs1,nhs2)+PD(ns1)*PD(ns2) & + ES(nhs1,nhs2) = ES(nhs1,nhs2)+PD(ns1)*PD(ns2) & *WDL(nh1,nde)*scale_factors_2d(ns1,ne)*scale_factors_2d(ns2,ne) endif !nhj2=nhj1 enddo !ns2 @@ -943,30 +1295,30 @@ subroutine zdes(ndata_on_elem,ne,ES,PG,WDL,WG,sobelov_wts,XIDL) enddo !ns1 enddo !nde - ns1=0 + ns1 = 0 nhs1 = nhs1_for_nhj1 - do nn1=1,num_elem_nodes - do nk1=1,num_deriv - nhs1=nhs1+1 - ns1=ns1+1 - nhs2=0 - do nhj2=1,num_fit !columns - ns2=0 - do nn2=1,num_elem_nodes - do nk2=1,num_deriv - nhs2=nhs2+1 - ns2=ns2+1 + do nn1 = 1,num_elem_nodes + do nk1 = 1,num_deriv + nhs1 = nhs1+1 + ns1 = ns1+1 + nhs2 = 0 + do nhj2 = 1,num_fit !columns + ns2 = 0 + do nn2 = 1,num_elem_nodes + do nk2 = 1,num_deriv + nhs2 = nhs2+1 + ns2 = ns2+1 if(nhj2.EQ.nhj1) then !to avoid coupling for now - SUM2=0.0_dp - do ng=1,num_gauss - SUM3=0.0_dp - do nu=2,6 - SUM3=SUM3+ & + SUM2 = 0.0_dp + do ng = 1,num_gauss + SUM3 = 0.0_dp + do nu = 2,6 + SUM3 = SUM3+ & PG(ns1,nu,ng)*PG(ns2,nu,ng)*sobelov_wts(nu,ne) enddo !nu - SUM2=SUM2+SUM3*WG(ng) + SUM2 = SUM2+SUM3*WG(ng) enddo !ng - ES(nhs1,nhs2)=ES(nhs1,nhs2)+(SUM2*sobelov_wts(0,ne))* & + ES(nhs1,nhs2) = ES(nhs1,nhs2)+(SUM2*sobelov_wts(0,ne))* & scale_factors_2d(ns1,ne)*scale_factors_2d(ns2,ne) endif !nhj2=nhj1 enddo !nk2 @@ -976,153 +1328,64 @@ subroutine zdes(ndata_on_elem,ne,ES,PG,WDL,WG,sobelov_wts,XIDL) enddo !nn1 enddo !nhj1 - end subroutine zdes + call enter_exit(sub_name,2) -!!! ########################################################################## - - subroutine zpze_fit(ne,fit_soln_local,fit_soln) - -!!! dummy arguments - integer,intent(in) :: ne - real(dp) :: fit_soln_local(:,:) - real(dp) :: fit_soln(:,:,:,:) -!!! local variables - integer :: nh,nk,nn,np,ns,nv - - do nh=1,num_fit - ns=0 - do nn=1,num_elem_nodes - np=elem_nodes_2d(nn,ne) - nv=elem_versn_2d(nn,ne) - do nk=1,num_deriv - ns=ns+1 - fit_soln_local(ns,nh)=fit_soln(nk,nv,nh,np)*scale_factors_2d(ns,ne) - enddo !nk - enddo !nn - enddo !nhx - - end subroutine zpze_fit + end subroutine make_element_matrices !!! ########################################################################## - subroutine calculate_ny_maps(npny,num_depvar,nynp,nynr) + subroutine calculate_ny_maps(npny,num_depvar,nynp) !!! dummy arguments - integer :: npny(0:,:),num_depvar,nynp(:,:,:,:),nynr(0:) + integer :: npny(:,:),num_depvar,nynp(:,:,:,:) !!! local variables integer nh,nk,np,nv,ny + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'calculate_ny_maps' + call enter_exit(sub_name,1) !*** Initialise mapping arrays - nynp=0 - npny=0 - nynr=0 + nynp = 0 + npny = 0 !*** Set up mapping arrays ny = 0 - nynr(0)=0 - do nh=1,num_fit - do np=1,num_nodes_2d - do nv=1,node_versn_2d(np) - do nk=1,num_deriv - ny=ny+1 - nynr(0)=nynr(0)+1 - nynr(nynr(0))=ny + do nh = 1,num_fit + do np = 1,num_nodes_2d + do nv = 1,node_versn_2d(np) + do nk = 1,num_deriv + ny = ny+1 nynp(nk,nv,nh,np) = ny - npny(0,ny)=1 !mesh dof is node based - npny(1,ny)=nk - npny(2,ny)=nv - npny(3,ny)=nh - npny(4,ny)=np - npny(5,ny)=1 + npny(1,ny) = nk + npny(2,ny) = nv + npny(3,ny) = nh + npny(4,ny) = np enddo !nk enddo !nv enddo !np enddo !njj num_depvar = ny - end subroutine calculate_ny_maps + call enter_exit(sub_name,2) -!!! ########################################################################## - - subroutine define_2d_elements(ELEMFILE) + end subroutine calculate_ny_maps - character(len=*) :: ELEMFILE - - ! Local Variables - integer :: ierror,ne,nn,noelem,np,number_of_elements - character(len=132) :: ctemp1 - - - open(10, file=ELEMFILE, status='old') - - read_number_of_elements : do - read(unit=10, fmt="(a)", iostat=ierror) ctemp1 - if(index(ctemp1, "elements")> 0) then - call get_final_integer(ctemp1,number_of_elements) - exit read_number_of_elements - endif - end do read_number_of_elements - - num_elems_2d=number_of_elements - if(.not.allocated(elems_2d)) allocate(elems_2d(num_elems_2d)) - if(.not.allocated(elem_nodes_2d)) allocate(elem_nodes_2d(4,num_elems_2d)) - if(.not.allocated(elem_versn_2d)) allocate(elem_versn_2d(4,num_elems_2d)) - - noelem=1 - - read_an_element : do - !.......read element number - read(unit=10, fmt="(a)", iostat=ierror) ctemp1 - if(index(ctemp1, "Element")> 0) then - call get_final_integer(ctemp1,ne) !get element number - elems_2d(noelem)=ne - noelem=noelem+1 - - read_element_nodes : do - read(unit=10, fmt="(a)", iostat=ierror) ctemp1 - if(index(ctemp1, "global")> 0) then !found the correct line - call get_four_nodes(ne,ctemp1) !number of versions for node np - ! note that only the ne'th data of elem_nodes_2d is passed to 'get_four_nodes' - do nn=1,4 - np=elem_nodes_2d(nn,ne) - if(node_versn_2d(np).gt.1)then - read(unit=10, fmt="(a)", iostat=ierror) ctemp1 !contains version# for njj=1 - read(unit=10, fmt="(a)", iostat=ierror) ctemp1 !contains version# for njj=1 - read(unit=10, fmt="(a)", iostat=ierror) ctemp1 !contains version# for njj=1 - call get_final_integer(ctemp1,elem_versn_2d(nn,ne)) !get version# - else - elem_versn_2d(nn,ne)= 1 - endif !nversions - enddo !nn - exit read_element_nodes - endif !index - end do read_element_nodes - - if(noelem.gt.number_of_elements) exit read_an_element - endif - - end do read_an_element - - close(10) - - call element_connectivity_2d - call line_segments_for_2d_mesh - - end subroutine define_2d_elements - !!! ########################################################################## - subroutine define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) + subroutine define_xi_closest(data_elem,data_on_elem,elem_list,ndata_on_elem,data_xi,first) !!! find the closest xi location on a 2d mesh surface to each data point implicit none -!!! dummy arguments + integer,intent(in) :: elem_list(:) integer :: data_elem(:),data_on_elem(:,:),ndata_on_elem(:) real(dp) :: data_xi(:,:) logical,intent(in) :: first !!! local variables integer :: i,n_check,ne_checklist(5),IT,ITMAX=20,nd,ne,neadj,nelast,neold,ni,nj - real(dp) :: sqmax,sqnd,temp,xe(num_deriv_elem,num_coords),xi(3) + real(dp) :: sqmax,sqnd,temp,elem_xyz(num_deriv_elem,num_coords),xi(3) real(dp),allocatable :: sq(:) logical :: found @@ -1130,6 +1393,12 @@ subroutine define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) character(len=200) :: exfile character(len=1) :: string_ne1 character(len=2) :: string_ne2 + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'define_xi_closest' + call enter_exit(sub_name,1) allocate(sq(num_data)) @@ -1139,34 +1408,15 @@ subroutine define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) sq = 0.0_dp xi = 0.5_dp -!!! start by finding the closest centre of an element to each data point -! do ne = 1,num_elems_2d -! call xpxe(ne,xe) -! do nd = 1,num_data -! sqnd = 0.0_dp -! do nj=1,num_coords -! temp = pxi(1,xi,xe(1,nj))-data_xyz(nj,nd) -! sqnd = sqnd+temp**2 -! enddo !nj -! if(data_elem(nd).eq.0.or.sqnd.lt.sq(nd)) then -! data_xi(1:2,nd) = xi(1:2) -! if(nd.eq.3976)then -! write(*,*) 'initial closest=',ne -! endif -! data_elem(nd) = ne -! sq(nd) = sqnd -! endif -! enddo ! nd -! enddo ! ne - if(first)then ! check every element for every data point do nd = 1,num_data sqmax = 1.0e4_dp*1.0e4_dp - do ne = 1,num_elems_2d + do i = 1,count(elem_list/=0) !num_elems_2d + ne = get_local_elem_2d(elem_list(i)) ! elem_list stores global elements xi = 0.5_dp - call xpxe(ne,xe) + call node_to_local_elem(ne,elem_xyz) found = .false. - call project_orthogonal(nd,SQND,xe,xi,found) + call project_orthogonal(nd,SQND,elem_xyz,xi,found) if(abs(xi(1)).ge.-zero_tol.and.abs(xi(1)).lt.1.0_dp+zero_tol.and. & abs(xi(2)).ge.zero_tol.and.abs(xi(2)).lt.1.0_dp+zero_tol) then if(sqnd.lt.sqmax)then @@ -1208,9 +1458,9 @@ subroutine define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) else xi = 0.5_dp endif - call xpxe(ne,xe) + call node_to_local_elem(ne,elem_xyz) found = .true. !find nearest point in element - call project_orthogonal(nd,sqnd,xe,xi,found) + call project_orthogonal(nd,sqnd,elem_xyz,xi,found) if(abs(xi(1)).ge.-zero_tol.and.abs(xi(1)).lt.1.0_dp+zero_tol.and. & abs(xi(2)).ge.zero_tol.and.abs(xi(2)).lt.1.0_dp+zero_tol) then if(sqnd.lt.sqmax)then @@ -1239,60 +1489,36 @@ subroutine define_xi_closest(data_elem,data_on_elem,ndata_on_elem,data_xi,first) enddo deallocate(sq) - - exfile = 'temp.exdata' - open(10, file = exfile, status = 'replace') - - do ne = 1,num_elems_2d - !** write the group name - if(ne.lt.10)then - write(string_ne1,'(i1)') ne - write(10,'( '' Group name: '',A)') 'datapoints_'//string_ne1 - else - write(string_ne2,'(i2)') ne - write(10,'( '' Group name: '',A)') 'datapoints_'//string_ne2 - endif - write(10,'(1X,''#Fields=1'')') - write(10,'(1X,''1) coordinates, coordinate, rectangular cartesian, #Components=3'')') - write(10,'(1X,'' x. Value index= 1, #Derivatives=0'')') - write(10,'(1X,'' y. Value index= 2, #Derivatives=0'')') - write(10,'(1X,'' z. Value index= 3, #Derivatives=0'')') - - do n_data = 1,ndata_on_elem(ne) - nd = data_on_elem(ne,n_data) - write(10,'(1X,''Node: '',I9)') nd - write(10,'(1X,3E13.5)') (data_xyz(nj,nd),nj=1,num_coords) - enddo !n_data - enddo !ne - close(10) + call enter_exit(sub_name,2) + end subroutine define_xi_closest !!! ########################################################################## subroutine solve_geometry_fit(data_on_elem,ndata_on_elem,num_depvar,& - elem_list,not_1,not_2,npny,nynp,nynr,nyny,data_xi,cyny,sobelov_wts,& + elem_list,not_1,not_2,npny,nynp,nyny,data_xi,cyny,sobelov_wts,& fit_soln,fix_bcs) !!! dummy arguments integer :: data_on_elem(:,:),ndata_on_elem(:),not_1,not_2,num_depvar,& - elem_list(0:),npny(0:,:),nynp(:,:,:,:),nynr(0:),nyny(0:,:) + elem_list(:),npny(:,:),nynp(:,:,:,:),nyny(0:,:) real(dp) :: data_xi(:,:),cyny(0:,:),sobelov_wts(0:,:),fit_soln(:,:,:,:) logical :: fix_bcs(:) !!! local variables - integer :: l,LGE2(3*16,2),ne,nh,nhs1,nhs2,NHST(2), & + integer :: l,ny_local(3*16),n_dof,ne,nh,nh1,nh2,nhs1,nhs2, & nk,no1,no2,no_nynr1,no_nynr2,noy1,noy2,np,nv,ny1,ny2,ny3,nyo1,nz,nzz - integer,allocatable :: nony(:,:,:) + integer,allocatable :: nony(:,:) integer,allocatable :: nyno(:,:,:) real(dp) :: co1,co2,ER(num_fit*num_deriv_elem),ES(3*16,3*16),& - fit_soln_local(16,3),PG(16,6,9),WG(9) - real(dp),allocatable :: cony(:,:,:) - real(dp),allocatable :: cyno(:,:,:) + fit_soln_local(16,3) + real(dp),allocatable :: cony(:) + real(dp),allocatable :: cyno(:,:) real(dp),allocatable :: GR(:) ! right-hand-side vector real(dp),allocatable :: GRR(:) ! reduced right-hand-side vector real(dp),allocatable :: incr_soln(:) ! current solution returned from solver - logical :: FIRST_A,UPDATE_MATRIX + logical :: FIRST_A ! make all of these allocatable! real(dp),dimension(nsize_gkk) :: GKK @@ -1300,92 +1526,82 @@ subroutine solve_geometry_fit(data_on_elem,ndata_on_elem,num_depvar,& ! doesn't like allocating these! gives different answer for errors ! real(dp),allocatable :: GKK(:) ! real(dp),allocatable :: GK(:) - real(dp),dimension(3,nmax_data_elem) :: WDL - real(dp),dimension(2,nmax_data_elem) :: XIDL - + integer :: np_temp,i + + character(len=60) :: sub_name - WG = [7.7160493827160628e-2_dp, 0.12345679012345677_dp, 7.7160493827160628e-2_dp,& - 0.12345679012345677_dp, 0.19753086419753044_dp, 0.12345679012345677_dp,& - 7.7160493827160628e-2_dp, 0.12345679012345677_dp, 7.7160493827160628e-2_dp] + ! -------------------------------------------------------------------------- + sub_name = 'solve_geometry_fit' + call enter_exit(sub_name,1) + allocate(incr_soln(num_depvar)) - allocate(nony(0:1,num_depvar,2)) + allocate(nony(0:1,num_depvar)) allocate(nyno(0:5,num_depvar,2)) - allocate(cony(0:1,num_depvar,2)) - allocate(cyno(0:5,num_depvar,2)) + allocate(cony(num_depvar)) + allocate(cyno(0:5,num_depvar)) allocate(GR(num_depvar)) allocate(GRR(num_depvar)) -! allocate(GK(num_depvar*num_depvar)) -! allocate(GKK(num_depvar*num_depvar)) - call gauss1(PG) + !*** Calculate solution mapping arrays for the current fit variable + call globalf(nony,not_1,not_2,npny,nyno,nynp,nyny,cony,cyno,cyny,fix_bcs) + + if(NOT_2.EQ.0) then + write(*,'('' >>The number of unknowns is zero'')') + stop + endif - UPDATE_MATRIX=.TRUE. - FIRST_A=.TRUE. + FIRST_A = .TRUE. - GR=0.0_dp + GR = 0.0_dp - do l=1,elem_list(0) !loop over elements in the fit - ne=elem_list(l) - call melgef(LGE2,ne,NHST,nynp) - ER=0.0_dp - ES=0.0_dp - call zpze_fit(ne,fit_soln_local,fit_soln) !gets fit_soln_local for element ne - call zder(data_on_elem,ndata_on_elem,ne,data_xi,ER,PG,WDL,WG,& - sobelov_wts,XIDL,fit_soln_local) - call zdes(ndata_on_elem,ne,ES,PG,WDL,WG,sobelov_wts,XIDL) + do l = 1,count(elem_list/=0) !loop over elements in the fit + ne = get_local_elem_2d(elem_list(l)) ! elem_list stores global elements + + call make_element_matrices(ne,fit_soln_local,fit_soln, & + data_on_elem,ndata_on_elem,data_xi,ER,ES,sobelov_wts) - !*** Assemble element stiffness matrix into global system. - do nhs1=1,NHST(1) !3 dependent variables - ny1=IABS(LGE2(nhs1,1)) + call local_dof(n_dof,ne,ny_local,nynp) + + ! Assemble element matrices into global matrices + do nh1 = 1,n_dof + ny1 = ny_local(nh1) if(ny1.eq.0)then write(*,'('' No dependent variable for node in element'',i6,'': are & &you sure you have set up versions correctly?'')') ne stop endif - GR(ny1)=GR(ny1)+ER(nhs1) - do nhs2=1,NHST(2) !3 dependent variables - ny2=IABS(LGE2(nhs2,2)) - nz=ny1+(ny2-1)*num_depvar - GK(nz)=GK(nz)+ES(nhs1,nhs2) - enddo !nhs2 - enddo !nhs1 + GR(ny1) = GR(ny1) + ER(nh1) + do nh2 = 1,n_dof + ny2 = ny_local(nh2) + nz = ny1+(ny2-1)*num_depvar + GK(nz) = GK(nz) + ES(nh1,nh2) + enddo !nh2 + enddo !nh1 enddo !l (ne) - !*** Calculate solution mapping arrays for the current fit variable - call globalf(nony,not_1,not_2,npny,nyno,nynp,nyny,cony,cyno,cyny,fix_bcs) - - if(NOT_2.EQ.0) then - write(*,'('' >>The number of unknowns is zero'')') - stop - endif - !----------------------- generate reduced system ----------------------- - GKK=0.0_dp - GRR=0.0_dp + GKK = 0.0_dp + GRR = 0.0_dp !*** generate the reduced system of equations - do no_nynr1=1,nynr(0) !loop global rows of GK - ny1=nynr(no_nynr1) !is row # - do noy1=1,nony(0,ny1,1) !loop over #no's attached to ny1 - no1=nony(noy1,ny1,1) !no# attached to row ny1 - co1=cony(noy1,ny1,1) !coupling coeff for row mapping + do ny1 = 1,num_depvar !loop global rows of GK + do noy1 = 1,nony(0,ny1) !loop over #no's attached to ny1 + no1 = nony(noy1,ny1) !no# attached to row ny1 + co1 = cony(ny1) !coupling coeff for row mapping ! ie row_no1=a*row_ny1+b*row_ny2 - GRR(no1)=GRR(no1)+GR(ny1)*co1 !get reduced R.H.S.vector - do no_nynr2=1,nynr(0) !loop over #cols of GK - ny2=nynr(no_nynr2) !is global variable # - ny3=getnyr(npny,ny2,nynp) + GRR(no1) = GRR(no1)+GR(ny1)*co1 !get reduced R.H.S.vector + do ny2 = 1,num_depvar !loop over #cols of GK !local GK var # - nz=ny1+(ny3-1)*num_depvar - if(nz.NE.0) then - do noy2=1,nony(0,ny2,2) !loop over #no's for ny2 - no2=nony(noy2,ny2,2) !no# attached to ny2 - co2=cony(noy2,ny2,2) !coup coeff col mapping + nz = ny1+(ny2-1)*num_depvar + if(nz.ne.0) then + do noy2 = 1,nony(0,ny2) !loop over #no's for ny2 + no2 = nony(noy2,ny2) !no# attached to ny2 + co2 = cony(ny2) !coup coeff col mapping ! i.e. var_no1=a*var_ny1+b*var_ny2 - nzz=no1+(no2-1)*NOT_1 - write(*,*) 'nzz',nzz - if(nzz.NE.0) GKK(nzz)=GKK(nzz)+GK(nz)*co1*co2 + nzz = no1+(no2-1)*NOT_1 + if(nzz.ne.0) GKK(nzz) = GKK(nzz)+GK(nz)*co1*co2 enddo !noy2 endif enddo !no_nynr2 @@ -1393,22 +1609,18 @@ subroutine solve_geometry_fit(data_on_elem,ndata_on_elem,num_depvar,& enddo !no_nynr1 !-------------- solve reduced system of linear equations --------------- - !Commented out since subroutines called further are temporarily unavailable - write(*,*) NOT_1,NOT_2, num_depvar, size(GKK), GKK(1:10), size(GRR), GRR(1:10) - write(*,*) size(incr_soln), incr_soln(1:10) - !pause - !call direct_solver(NOT_1,NOT_1,NOT_2,num_depvar,GKK,GRR,incr_soln,FIRST_A) - - do no1=1,NOT_2 ! for each unknown - do nyo1=1,nyno(0,no1,2) - ny1=nyno(nyo1,no1,2) ! the dependent variable number - co1=cyno(nyo1,no1,2) ! the weighting for mapped variables - nk=npny(1,ny1) ! derivative number - nv=npny(2,ny1) ! version number - nh=npny(3,ny1) ! dependent variable number - np=npny(4,ny1) ! node number - fit_soln(nk,nv,nh,np) = fit_soln(nk,nv,nh,np) + incr_soln(no1)*co1 - ! current fit solution = previous + increment + call solve_fit_system(NOT_1,NOT_2,num_depvar,GKK,GRR,incr_soln) + + do no1 = 1,NOT_2 ! for each unknown + do nyo1 = 1,nyno(0,no1,1) + ny1 = nyno(nyo1,no1,1) ! the dependent variable number + co1 = cyno(nyo1,no1) ! the weighting for mapped variables + nk = npny(1,ny1) ! derivative number + nv = npny(2,ny1) ! version number + nh = npny(3,ny1) ! dependent variable number + np = npny(4,ny1) ! node number + !current fit solution = previous + increment + fit_soln(nk,nv,nh,np) = fit_soln(nk,nv,nh,np) + incr_soln(no1)*co1 enddo !nyo1 enddo !no1 @@ -1422,18 +1634,18 @@ subroutine solve_geometry_fit(data_on_elem,ndata_on_elem,num_depvar,& deallocate(cyno) deallocate(GR) deallocate(GRR) -! deallocate(GK) -! deallocate(GKK) + call enter_exit(sub_name,2) + end subroutine solve_geometry_fit !!! ########################################################################## - subroutine project_orthogonal(nd,SQ,xe,xi,inelem) + subroutine project_orthogonal(nd,SQ,elem_xyz,xi,inelem) !!! dummy arguments integer :: nd - real(dp) :: sq,xe(num_deriv_elem,num_coords),xi(:) + real(dp) :: sq,elem_xyz(num_deriv_elem,num_coords),xi(:) logical :: inelem !!! local variables integer :: IT,ITMAX,BOUND(2),it2,ni,nifix,nj @@ -1444,13 +1656,15 @@ subroutine project_orthogonal(nd,SQ,xe,xi,inelem) TOL2,V(2),V1,V2,VMAX=1.0_dp,W,XILIN(2),Z(3) logical :: CONVERGED,ENFORCE(2),FREE,NEWTON + ! -------------------------------------------------------------------------- + ITMAX = 10 ! max # iterations to use DELTA = VMAX/4.0_dp TOL = 5.0_dp*LOOSE_TOL !must be > sqrt(eps) or SQLIN<=SQ check may not work TOL2 = TOL**2 SQ = 0.0_dp do nj=1,num_coords - Z(nj) = PXI(1,XI,XE(1,nj)) + Z(nj) = PXI(1,XI,elem_xyz(1,nj)) DZ(nj) = Z(nj)-data_xyz(nj,nd) SQ = SQ+DZ(nj)**2 enddo !nj @@ -1459,8 +1673,8 @@ subroutine project_orthogonal(nd,SQ,xe,xi,inelem) do WHILE(.NOT.CONVERGED.AND.IT.LT.ITMAX) DSQXI = 0.0_dp do nj=1,num_coords - DZXI(nj,1) = PXI(2,XI,XE(1,nj)) - DZXI(nj,2) = PXI(4,XI,XE(1,nj)) + DZXI(nj,1) = PXI(2,XI,elem_xyz(1,nj)) + DZXI(nj,2) = PXI(4,XI,elem_xyz(1,nj)) DSQXI(1) = DSQXI(1)+DZXI(nj,1)*DZ(nj) DSQXI(2) = DSQXI(2)+DZXI(nj,2)*DZ(nj) enddo !nj @@ -1480,9 +1694,9 @@ subroutine project_orthogonal(nd,SQ,xe,xi,inelem) D2SQXI = 0.0_dp do nj=1,num_coords - D2ZXI(nj,1,1) = PXI(3,XI,XE(1,nj)) - D2ZXI(nj,1,2) = PXI(5,XI,XE(1,nj)) - D2ZXI(nj,2,2) = PXI(5,XI,XE(1,nj)) + D2ZXI(nj,1,1) = PXI(3,XI,elem_xyz(1,nj)) + D2ZXI(nj,1,2) = PXI(5,XI,elem_xyz(1,nj)) + D2ZXI(nj,2,2) = PXI(5,XI,elem_xyz(1,nj)) D2SQXI(1,1) = D2SQXI(1,1)+DZXI(nj,1)*DZXI(nj,1)+D2ZXI(nj,1,1)*DZ(nj) D2SQXI(1,2) = D2SQXI(1,2)+DZXI(nj,1)*DZXI(nj,2)+D2ZXI(nj,1,2)*DZ(nj) D2SQXI(2,2) = D2SQXI(2,2)+DZXI(nj,2)*DZXI(nj,2)+D2ZXI(nj,2,2)*DZ(nj) @@ -1605,7 +1819,7 @@ subroutine project_orthogonal(nd,SQ,xe,xi,inelem) !*** Calculate new distance SQLIN=0.0_dp do nj=1,num_coords - Z(nj)=PXI(1,XILIN,XE(1,nj)) + Z(nj)=PXI(1,XILIN,elem_xyz(1,nj)) DZ(nj)=Z(nj)-data_xyz(nj,nd) SQLIN=SQLIN+DZ(nj)**2 enddo @@ -1653,6 +1867,160 @@ end subroutine project_orthogonal !!! ########################################################################## + subroutine solve_fit_system(M,N,num_depvar,A,B,X) + + integer :: M,N,num_depvar + real(dp) :: A(:),B(:),X(:) +!!! local variables + integer,allocatable :: pivots(:) + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'solve_fit_system' + call enter_exit(sub_name,1) + + allocate(pivots(num_depvar*num_depvar)) + + ! LU Decomposition + call lu_decomp(M,N,pivots,A) + ! Solve the problem + X(1:m) = B(1:m) + call lu_solve(M,N,pivots,A,X) + + deallocate(pivots) + + call enter_exit(sub_name,2) + + end subroutine solve_fit_system + +!!! ########################################################################## + + subroutine lu_decomp(M,N,pivots,A) + + integer :: M,N,pivots(:) + real(dp) :: A(M, * ) + integer :: j,j_pivot + real(dp),allocatable :: temp_vec(:) + character(len=60) :: sub_name + + ! -------------------------------------------------------------------------- + + sub_name = 'lu_decomp' + call enter_exit(sub_name,1) + + allocate(temp_vec(M)) + + do j = 1, min(M,N) + j_pivot = j-1 + indexmax( M-j+1, A(j,j)) + pivots(j) = j_pivot + if(abs(A(j_pivot,j)).gt.zero_tol )then + if(j_pivot.ne.j)then + ! swap rows a(j,:) and a(j_pivot,:) + temp_vec(1:n) = a(j,1:n) + a(j,1:n) = a(j_pivot,1:n) + a(j_pivot,1:n) = temp_vec(1:n) + endif + if(j.lt.M) & + ! scale vector by a constant (a(j+1,j) by 1/(a(j,j)) + call scale_row_lu(M-j,1.0_dp/A(j,j),A(j+1,j)) + endif + if(j.lt.MIN(M,N))then + ! A = A + x*y' + call add_to_row_lu(M,M-j,N-j,A(j+1,j),A(j,j+1),A(j+1,j+1)) + endif + enddo + + deallocate(temp_vec) + + call enter_exit(sub_name,2) + + end subroutine lu_decomp +!!! ########################################################################## + + subroutine scale_row_lu(n,da,dx) + + real(dp) :: da,dx(*) + integer :: i,n + + do i = 1,n + dx(i) = da*dx(i) + enddo + + end subroutine scale_row_lu + +!!! ########################################################################## + + subroutine add_to_row_lu(M,maxrow,N,X,Y,A) + integer :: M,maxrow,N + real(dp) :: A(M,*),X(*),Y(*) + integer :: j, JY + + JY = 1 + do j = 1, N !n-j + if(abs(Y(JY)).gt.zero_tol)then + A(1:maxrow,j) = A(1:maxrow,j) - X(1:maxrow)*Y(jy) + endif + JY = JY + M + enddo + + end subroutine add_to_row_lu + +!!! ########################################################################## + + subroutine lu_solve(M,N,pivots,A,B) + + integer :: M,N,pivots(:) + real(dp) :: A(M,*),B(M, * ) + integer :: i,k,pivot_row + real(dp) :: temp + + ! swap row i and pivot_row for each of rows 1..N + do i = 1,N + pivot_row = pivots(i) + if(pivot_row.ne.i)then + temp = B(i,1) + B(i,1) = B(pivot_row,1) + B(pivot_row,1) = temp + endif + enddo + + ! Solve L*X = B, overwriting B with X. + do k = 1,N + if(abs(B(k,1)).gt.zero_tol) & + B(k+1:N,1) = B(k+1:N,1) - B(k,1)*A(k+1:N,k) + enddo + + ! Solve U*X = B, overwriting B with X. + do k = N,1,-1 + if(abs(B(k,1)).gt.zero_tol ) then + B(k,1) = B(k,1)/A(k,k) + B(1:k-1,1) = B(1:k-1,1) - B(k,1)*A(1:k-1,k) + endif + enddo + + end subroutine lu_solve + + function indexmax(n,dx) + ! return the index of entry with largest abs value + real(dp) :: dx(*),dmax + integer :: i,n + integer :: indexmax + + indexmax = 1 + if(n.gt.1)then + dmax = abs(dx(1)) + do i = 2,n + if(abs(dx(i)).gt.dmax)then + indexmax = i + dmax = abs(dx(i)) + endif + enddo + endif + + end function indexmax + +!!! ########################################################################## end module surface_fitting From bca17571a6e97d85bdda9f556eae8b938a1af4b2 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Mon, 21 Jun 2021 20:17:12 +1200 Subject: [PATCH 04/25] subroutines to refine 1d tree, and reorder a refined tree to be sequentially numbered --- src/bindings/c/geometry.c | 12 ++ src/bindings/c/geometry.f90 | 36 ++++++ src/bindings/c/geometry.h | 2 + src/lib/geometry.f90 | 227 ++++++++++++++++++++++++++++++++++++ 4 files changed, 277 insertions(+) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index f37746cc..2408a9d8 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -22,6 +22,8 @@ void define_rad_from_geom_c(const char *order_system, int *order_system_len, dou const char *group_type, int *group_type_len, const char *group_options, int *group_options_len); void element_connectivity_1d_c(void); void evaluate_ordering_c(void); +void refine_1d_elements_c(int *elemlist_len, int elemlist[], int *nrefinements); +void renumber_tree_in_order_c(void); void set_initial_volume_c(int *Gdirn, double *COV, double *total_volume, double *Rmax, double *Rmin); void volume_of_mesh_c(double *volume_model, double *volume_tree); void write_elem_geometry_2d_c(const char *ELEMFILE, int *filename_len); @@ -133,6 +135,16 @@ void evaluate_ordering() evaluate_ordering_c(); } +void refine_1d_elements(int elemlist_len, int elemlist[], int nrefinements) +{ + refine_1d_elements_c(&elemlist_len, elemlist, &nrefinements); +} + +void renumber_tree_in_order() +{ + renumber_tree_in_order_c(); +} + void set_initial_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin) { set_initial_volume_c(&Gdirn, &COV, &total_volume, &Rmax, &Rmin); diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index c50a44aa..4fbca29b 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -379,6 +379,42 @@ subroutine evaluate_ordering_c() bind(C, name="evaluate_ordering_c") end subroutine evaluate_ordering_c +! +!################################################################################### +! + + subroutine refine_1d_elements_c(elemlist, elemlist_len, nrefinements) bind(C, name="refine_1d_elements_c") + use geometry, only: refine_1d_elements + implicit none + + integer,intent(in) :: elemlist_len + integer,intent(in) :: elemlist(elemlist_len) + integer,intent(in) :: nrefinements + +#if defined _WIN32 && defined __INTEL_COMPILER + call so_refine_1d_elements(elemlist, nrefinements) +#else + call refine_1d_elements(elemlist, nrefinements) +#endif + + end subroutine refine_1d_elements_c + +! +!################################################################################### +! +! + subroutine renumber_tree_in_order_c() bind(C, name="renumber_tree_in_order_c") + use geometry, only: renumber_tree_in_order + implicit none + +#if defined _WIN32 && defined __INTEL_COMPILER + call so_renumber_tree_in_order +#else + call renumber_tree_in_order +#endif + + end subroutine renumber_tree_in_order_c + !################################################################################### ! !>*set_initial_volume:* assigns a volume to terminal units appended on a tree structure diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index 0f743bdb..9e938e9b 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -22,6 +22,8 @@ SHO_PUBLIC void define_rad_from_geom(const char *ORDER_SYSTEM, double CONTROL_PA double START_RAD, const char *GROUP_TYPE, const char *GROUP_OPTIONS); SHO_PUBLIC void element_connectivity_1d(); SHO_PUBLIC void evaluate_ordering(); +SHO_PUBLIC void refine_1d_elements(int elemlist_len, int elemlist[], int nrefinements); +SHO_PUBLIC void renumber_tree_in_order(); SHO_PUBLIC void set_initial_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin); SHO_PUBLIC void volume_of_mesh(double *volume_model, double *volume_tree); SHO_PUBLIC void write_elem_geometry_2d(const char *ELEMFILE); diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 71447628..9eedfc2f 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -46,6 +46,8 @@ module geometry public make_data_grid public make_2d_vessel_from_1d public reallocate_node_elem_arrays + public refine_1d_elements + public renumber_tree_in_order public set_initial_volume public triangles_from_surface public volume_of_mesh @@ -3605,6 +3607,231 @@ subroutine geo_node_offset(node_xyz_offset) end subroutine geo_node_offset +!!!############################################################################# + + subroutine refine_1d_elements(elem_list_refine,num_refinements) +!!! Refines all elements from 1 up to num_elem_refine. Should be doing +!!! this for a list of specific elements only. + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_REFINE_1D_ELEMENTS :: REFINE_1D_ELEMENTS + + integer,intent(in) :: elem_list_refine(:) + integer,intent(in) :: num_refinements + + integer, allocatable :: node_list (:,:),new_units(:),temp_elem_units_below(:) + + integer :: num_elem_refine,i,ne,ne_new,node_end,node_start,np_new,& + nunits,num_elems_new,num_nodes_new,n_refine + real(dp) :: increment(3),refined_length + + num_elem_refine = count(elem_list_refine.ne.0) + + allocate(node_list(2,num_elems)) + node_list(1:2,1:num_elems) = elem_nodes(1:2,1:num_elems) + + num_nodes_new = num_nodes + num_refinements*num_elem_refine + num_elems_new = num_elems + num_refinements*num_elem_refine + + if(num_units.gt.0)then + allocate(new_units(num_units)) + new_units = 0 + nunits = 0 + allocate(temp_elem_units_below(num_elems_new)) + temp_elem_units_below(1:num_elems) = elem_units_below(1:num_elems) + endif + + call reallocate_node_elem_arrays(num_elems_new,num_nodes_new) + + np_new = num_nodes + ne_new = num_elems + + do i = 1,num_elem_refine + ne = elem_list_refine(i) + node_start = node_list(1,ne) + node_end = node_list(2,ne) + refined_length = elem_field(ne_length,ne)/dble(num_refinements+1) + increment(1:3) = elem_direction(1:3,ne)*refined_length + ! adjust the current element end node, length and volume + elem_nodes(2,ne) = np_new+1 + elem_field(ne_length,ne) = refined_length + elem_field(ne_vol,ne) = elem_field(ne_vol,ne)/dble(num_refinements+1) + + do n_refine = 1,num_refinements + np_new = np_new+1 + nodes(np_new) = np_new + node_xyz(1:3,np_new) = node_xyz(1:3,node_start) + increment(1:3) + + ne_new = ne_new+1 + elems(ne_new) = ne_new + elem_nodes(1,ne_new) = np_new + elem_nodes(2,ne_new) = np_new+1 ! is overwritten if 'last' element + + elem_field(ne_length,ne_new) = refined_length + elem_field(ne_radius,ne_new) = elem_field(ne_radius,ne) + elem_field(ne_vol,ne_new) = elem_field(ne_vol,ne) + elem_field(ne_vd_bel,ne_new) = elem_field(ne_vd_bel,ne) - elem_field(ne_vol,ne)*n_refine + elem_field(ne_vol_bel,ne_new) = elem_field(ne_vol_bel,ne) - elem_field(ne_vol,ne)*n_refine + elem_field(ne_a_A,ne_new) = elem_field(ne_a_A,ne) + elem_direction(1:3,ne_new) = elem_direction(1:3,ne) + elem_ordrs(1,ne_new) = elem_ordrs(1,ne) + if(num_units.gt.0) temp_elem_units_below(ne_new) = elem_units_below(ne) + node_start = np_new + + enddo + elem_nodes(2,ne_new) = node_end ! overwrites for just the 'last' element + enddo + + num_nodes = np_new + num_elems = ne_new + + if(num_units.gt.0)then + units = new_units + deallocate(elem_units_below) + allocate(elem_units_below(num_elems)) + elem_units_below = temp_elem_units_below + deallocate(new_units) + deallocate(temp_elem_units_below) + endif + + deallocate(node_list) + call element_connectivity_1d + elem_ordrs(no_type,:) = 1 ! 0 for respiratory, 1 for conducting + + end subroutine refine_1d_elements + +!!!############################################################################# + + subroutine renumber_tree_in_order + ! reorders a 1D tree network so that elements and nodes increase with order. + use math_utilities + + integer :: i,nchild,ne,ne0,ne_start,np,num_sorted,num_to_order,num_to_order_prev,& + nunit,old_ne,old_np + integer,allocatable :: elem_list(:),elem_back(:),elems_to_order(:), & + elems_to_order_next(:) + logical :: single + integer, allocatable :: temp_elem_ordrs(:,:),temp_elem_units_below(:), & + temp_elem_nodes(:,:),temp_elem_symmetry(:),temp_inv_node(:),temp_map_node(:) + real(dp),allocatable :: temp_elem_direction(:,:),temp_elem_field(:,:),temp_node_xyz(:,:) + + allocate (elem_list(num_elems)) + allocate (elem_back(num_elems)) + allocate (elems_to_order(num_elems)) + allocate (elems_to_order_next(num_elems)) + + ne_start = 1 ! this should be the stem element of current tree + elem_list(1) = ne_start ! the first element in the tree + elem_back(ne_start) = 1 + num_sorted = 0 + +!!! Set up the list of correctly ordered elements and nodes. + num_to_order = 1 + elems_to_order(1) = ne_start + do while(num_to_order.ne.0) !while still some to reorder + num_to_order_prev = num_to_order + num_to_order = 0 + do i = 1,num_to_order_prev !for parents in previous gen + ne0 = elems_to_order(i) + num_sorted = num_sorted+1 !increment counter + elem_list(num_sorted) = ne0 !store element # + elem_back(ne0) = num_sorted + single = .true. + do while (single) + if(elem_cnct(1,0,ne0).eq.1)then + ne = elem_cnct(1,1,ne0) !daughter element # + num_sorted = num_sorted+1 !increment counter + elem_list(num_sorted) = ne !store element # + elem_back(ne) = num_sorted + ne0 = ne + else if(elem_cnct(1,0,ne0).ge.2)then + do nchild = 1,elem_cnct(1,0,ne0) !for each child + ne = elem_cnct(1,nchild,ne0) !daughter element # + num_to_order = num_to_order+1 + elems_to_order_next(num_to_order) = ne + enddo !nchild + single = .false. + else if (elem_cnct(1,0,ne0).eq.0)then + single = .false. + endif + enddo !while + enddo !nz1 + elems_to_order = elems_to_order_next + enddo !while + +!!! Put values into temporary arrays; move to correct array positions. +!!! Assumes that new element and node numbering will start from 1. + +!!! at this point temp_elem_list has the order that we want. now transfer to arrays + allocate(temp_elem_ordrs(num_ord,num_elems)) + if(num_units.gt.0)then + allocate(temp_elem_units_below(num_elems)) + endif + allocate(temp_elem_nodes(2,num_elems)) + allocate(temp_elem_direction(3,num_elems)) + allocate(temp_elem_field(num_ne,num_elems)) + allocate(temp_elem_symmetry(num_elems)) + allocate(temp_inv_node(num_nodes)) + allocate(temp_map_node(num_nodes)) + allocate(temp_node_xyz(1:3,num_nodes)) + + temp_map_node(1) = 1 + temp_inv_node(1) = 1 + + do ne = 1,num_elems + old_ne = elem_list(ne) + temp_elem_ordrs(1:4,ne) = elem_ordrs(1:4,old_ne) + temp_elem_direction(1:3,ne) = elem_direction(1:3,old_ne) + temp_elem_field(:,ne) = elem_field(:,old_ne) + temp_elem_symmetry(ne) = elem_symmetry(old_ne) + temp_map_node(ne+1) = elem_nodes(2,old_ne) + temp_inv_node(elem_nodes(2,old_ne)) = ne+1 + if(num_units.gt.0)then + temp_elem_units_below(ne) = elem_units_below(old_ne) + endif + enddo + +!!! map the unordered node info to temporary node arrays + temp_node_xyz(1:3,1) = node_xyz(1:3,1) + do ne = 1,num_elems + np = ne+1 + old_ne = elem_list(ne) + old_np = temp_map_node(np) + temp_node_xyz(1:3,np) = node_xyz(1:3,old_np) + temp_elem_nodes(1,ne) = temp_inv_node(elem_nodes(1,old_ne)) + temp_elem_nodes(2,ne) = temp_inv_node(elem_nodes(2,old_ne)) + enddo + + if(num_units.gt.0)then + do nunit = 1,num_units + old_ne = units(nunit) + ne = elem_back(old_ne) + units(nunit) = ne + enddo + elem_units_below = temp_elem_units_below + endif + elem_ordrs = temp_elem_ordrs + elem_nodes = temp_elem_nodes + elem_direction = temp_elem_direction + elem_field = temp_elem_field + node_xyz = temp_node_xyz + + call element_connectivity_1d + + deallocate(elem_list) + deallocate(elem_back) + deallocate(elems_to_order) + deallocate(elems_to_order_next) + deallocate(temp_elem_ordrs) + if(num_units.gt.0) deallocate(temp_elem_units_below) + deallocate(temp_elem_nodes) + deallocate(temp_elem_direction) + deallocate(temp_elem_field) + deallocate(temp_elem_symmetry) + deallocate(temp_inv_node) + deallocate(temp_map_node) + deallocate(temp_node_xyz) + + end subroutine renumber_tree_in_order + !!!############################################################################# subroutine reallocate_node_elem_arrays(num_elems_new,num_nodes_new) From bab75ab8c64b752a58623df58c36f1a0edd15565 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 16 Jul 2021 13:39:07 +1200 Subject: [PATCH 05/25] bindings for specifying file, branch type, and refinement for add_mesh' --- src/bindings/c/geometry.c | 7 +- src/bindings/c/geometry.f90 | 12 +- src/bindings/c/geometry.h | 2 +- src/lib/geometry.f90 | 296 +++++++++++++++++++++++++++--------- src/lib/mesh_utilities.f90 | 24 +++ src/lib/ventilation.f90 | 1 + 6 files changed, 260 insertions(+), 82 deletions(-) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index 2408a9d8..07a2a8de 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -3,7 +3,7 @@ #include "string.h" -void add_mesh_c(const char *AIRWAY_MESHFILE, int *filename_len); +void add_mesh_c(const char *AIRWAY_MESHFILE, int *filename_len, const char *BRANCHTYPE, int *branchtype_len, int *n_refine); void add_matching_mesh_c(void); void append_units_c(void); void define_1d_elements_c(const char *ELEMFILE, int *filename_len); @@ -30,10 +30,11 @@ void write_elem_geometry_2d_c(const char *ELEMFILE, int *filename_len); void write_geo_file_c(int *ntype, const char *GEOFILE, int *filename_len); void write_node_geometry_2d_c(const char *NODEFILE, int *filename_len); -void add_mesh(const char *AIRWAY_MESHFILE) +void add_mesh(const char *AIRWAY_MESHFILE, const char *BRANCHTYPE, int n_refine ) { int filename_len = (int)strlen(AIRWAY_MESHFILE); - add_mesh_c(AIRWAY_MESHFILE, &filename_len); + int branchtype_len = (int)strlen(BRANCHTYPE); + add_mesh_c(AIRWAY_MESHFILE, &filename_len, BRANCHTYPE, &branchtype_len, &n_refine); } void add_matching_mesh() diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index 4fbca29b..a352df73 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -14,22 +14,24 @@ module geometry_c !################################################################################### ! !*add_mesh:* Reads in an ipmesh file and adds this mesh to the terminal branches of an existing tree geometry - subroutine add_mesh_c(AIRWAY_MESHFILE, filename_len) bind(C, name="add_mesh_c") + subroutine add_mesh_c(AIRWAY_MESHFILE, filename_len, BRANCHTYPE, branchtype_len, n_refine) bind(C, name="add_mesh_c") use iso_c_binding, only: c_ptr use utils_c, only: strncpy use other_consts, only: MAX_FILENAME_LEN use geometry, only: add_mesh implicit none - integer,intent(in) :: filename_len - type(c_ptr), value, intent(in) :: AIRWAY_MESHFILE + integer,intent(in) :: filename_len, branchtype_len, n_refine + type(c_ptr), value, intent(in) :: AIRWAY_MESHFILE, BRANCHTYPE character(len=MAX_FILENAME_LEN) :: filename_f + character(len=MAX_FILENAME_LEN) :: branchtype_f call strncpy(filename_f, AIRWAY_MESHFILE, filename_len) + call strncpy(branchtype_f, BRANCHTYPE, branchtype_len) #if defined _WIN32 && defined __INTEL_COMPILER - call so_add_mesh(filename_f) + call so_add_mesh(filename_f, branchtype_f, n_refine) #else - call add_mesh(filename_f) + call add_mesh(filename_f, branchtype_f, n_refine) #endif end subroutine add_mesh_c diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index 9e938e9b..776ca358 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -4,7 +4,7 @@ #include "symbol_export.h" -SHO_PUBLIC void add_mesh(const char *AIRWAY_MESHFILE); +SHO_PUBLIC void add_mesh(const char *AIRWAY_MESHFILE, const char *BRANCHTYPE, int n_refine); SHO_PUBLIC void add_matching_mesh(); SHO_PUBLIC void append_units(); SHO_PUBLIC void define_1d_elements(const char *ELEMFILE); diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 9eedfc2f..371f7c18 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -87,34 +87,47 @@ end subroutine allocate_node_arrays !!!############################################################################# - subroutine add_mesh(AIRWAY_MESHFILE) + subroutine add_mesh(meshfile, branchtype, n_refine) !*add_mesh:* Reads in an ipmesh file and adds this mesh to the terminal ! branches of an existing tree geometry !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_ADD_MESH" :: ADD_MESH - character(len=MAX_FILENAME_LEN), intent(in) :: AIRWAY_MESHFILE - ! Local parameters - character(len=100) :: buffer + integer,intent(in) :: n_refine + character(len=*), intent(in) :: meshfile + character(len=*), intent(in) :: branchtype + logical :: scale_to_unit = .false. + + integer,dimension(1000) :: element_temp,generation,parent_element,symmetry_temp + integer :: i,ibeg,iend,i_ss_end,j,n,nbranch,ne,ne0,ne_global,ne_grandparent, & + ne_parent,ne_parent0, & + ne_start,ne_u,ne_u0,ngen_parent,nlabel,np,np0,np_global,ntype,num_elems_new, & + num_nodes_new,num_parents,num_elems_to_add,nunit + integer :: ios = 0 + integer :: line = 0 integer, parameter :: fh = 15 - integer :: ios - integer :: line - integer :: i,ibeg,iend,i_ss_end,j,ne,ne0,ne_global,ne_parent,ne_start, & - ngen_parent,np,np0,np_global,& - num_elems_new,num_elems_to_add,num_nodes_new,nunit,nlabel - integer,dimension(1000) :: element_temp,generation, & - parent_element,symmetry_temp + integer :: np1,np2 + integer, allocatable :: parentlist(:) + real(dp) :: ratio real(dp),dimension(1000) :: length,radius,a_A - character(len=60) :: sub_name + real(dp) :: A(3,3),B(3),branch_angle,direction(3),dirn_parent(3), & + dirn_grandparent(3),normal(3),normal2(3) + real(dp),allocatable :: volume_below(:) + character(len=100) :: buffer,readfile - ! -------------------------------------------------------------------------- - - sub_name = 'add_mesh' - call enter_exit(sub_name,1) + if(index(meshfile, ".ipmesh")> 0) then !full filename is given + readfile = meshfile + else ! need to append the correct filename extension + readfile = trim(meshfile)//'.ipmesh' + endif + open(fh, file=readfile) - ios = 0 - line = 0 - open(fh, file=AIRWAY_MESHFILE) - + if(index(branchtype, "COND")>0 .or. index(branchtype, "cond")>0)then + ntype = 1 + elseif(index(branchtype, "RESP")>0 .or. index(branchtype, "resp")>0)then + ntype = 0 + endif + write(*,*) ntype ! = 1 + read(*,*) ! ios is negative if an end of record condition is encountered or if ! an endfile condition was detected. It is positive if an error was ! detected. ios is zero otherwise. @@ -124,7 +137,7 @@ subroutine add_mesh(AIRWAY_MESHFILE) do while (ios == 0) read(fh, '(A)', iostat=ios) buffer - ! line contains: element, parent element, generation, + ! line contains: element, parent element, generation, ! symmetry, length, outer radius, a/A ratio ! note that a/A ratio is always 1 for the conducting airways if (ios == 0) then @@ -156,14 +169,26 @@ subroutine add_mesh(AIRWAY_MESHFILE) endif enddo close(fh) - + num_elems_to_add = i - + + allocate(parentlist(num_elems)) + parentlist = 0 + num_parents = 0 + do ne = 1,num_elems + if(elem_cnct(1,0,ne).eq.0)then + num_parents = num_parents + 1 + parentlist(num_parents) = ne + endif + enddo + + !num_parents = count(parentlist.ne.0) + !!! increase the size of node and element arrays to accommodate the additional elements ! the number of nodes after adding mesh will be: - num_nodes_new = num_nodes + num_units*num_elems_to_add + num_nodes_new = num_nodes + num_parents*num_elems_to_add*n_refine ! the number of elems after adding mesh will be: - num_elems_new = num_elems + num_units*num_elems_to_add + num_elems_new = num_elems + num_parents*num_elems_to_add*n_refine call reallocate_node_elem_arrays(num_elems_new,num_nodes_new) ne = num_elems ! the starting local element number @@ -171,68 +196,152 @@ subroutine add_mesh(AIRWAY_MESHFILE) np = num_nodes ! the starting local node number np_global = nodes(np) ! assumes this is the highest node number (!!!) - do nunit = 1,num_units ! for all terminal branches, append the mesh - - ne_parent = units(nunit) ! local element number of terminal, to append to - ngen_parent = elem_ordrs(1,ne_parent) + do nbranch = 1,num_parents ! for all listed branches, append the mesh ne_start = ne !starting element number for the unit - do i=1,num_elems_to_add + do i = 1,num_elems_to_add - if(parent_element(i).eq.0)then - ne_parent = units(nunit) + if(parent_element(i).eq.0)then !first new elem to append; add to existing + ne_parent = parentlist(nbranch) ! local element number of terminal, to append to + ne_parent0 = ne_parent else - ne_parent = ne_start+parent_element(i) + ne_parent = ne_start+parent_element(i) & !adding to new + *n_refine !+(nunit-1)*num_elems_to_add*n_refine !!new line endif + ngen_parent = elem_ordrs(1,ne_parent) ne0 = ne_parent - np0 = elem_nodes(2,ne0) - - ne_global = ne_global + 1 ! new global element number - ne = ne + 1 ! new local element number - np_global = np_global + 1 !new global node number - np = np + 1 ! new local node number - - nodes(np) = np_global - elems(ne) = ne_global - - elem_nodes(1,ne) = np0 - elem_nodes(2,ne) = np - - elem_ordrs(1,ne) = ngen_parent + generation(i) - elem_ordrs(no_type,ne) = 1 ! ntype ! 0 for respiratory, 1 for conducting - elem_symmetry(ne) = symmetry_temp(i)+1 ! uses 0/1 in file; 1/2 in code - - ! record the element connectivity - elem_cnct(-1,0,ne) = 1 ! one parent branch - elem_cnct(-1,1,ne) = ne0 ! store parent element - elem_cnct(1,0,ne0) = elem_cnct(1,0,ne0) + 1 - elem_cnct(1,elem_cnct(1,0,ne0),ne0) = ne - - ! record the direction and location of the branch - do j=1,3 - elem_direction(j,ne) = elem_direction(j,ne0) - node_xyz(j,np) = node_xyz(j,np0) + & - elem_direction(j,ne)*length(i) - enddo !j + + ! for the branching angle and direction - + if(symmetry_temp(i).eq.1)then ! same as parent if symmetric + direction(:) = elem_direction(:,ne_parent) + else + ne_grandparent = get_parent_branch(ne_parent) + dirn_parent(:) = elem_direction(:,ne_parent) + if(ne_grandparent.eq.0)then + normal(1) = 0.0_dp + normal(2) = -1.0_dp/sqrt(2.0_dp) + normal(3) = 1.0_dp/sqrt(2.0_dp) + else + dirn_grandparent(:) = elem_direction(:,ne_grandparent) + if(check_vectors_same(dirn_parent,dirn_grandparent))then + normal(1) = 0.0_dp + normal(2) = -1.0_dp/sqrt(2.0_dp) + normal(3) = 1.0_dp/sqrt(2.0_dp) + else + normal = cross_product(dirn_parent,dirn_grandparent) !get normal to parent-grandparent + normal = unit_vector(normal) ! normalise + endif + endif + branch_angle = 25.0_dp * pi/180.0_dp + normal2 = cross_product(dirn_parent,normal) ! equation for the branching plane + normal2 = unit_vector(normal2) ! normalise + ! set up a mini linear system to solve: + A(1,:) = dirn_parent(:) !dotprod parent and new element + A(2,:) = normal(:) !dotprod normal and new element + A(3,:) = normal2(:) !dotprod plane and new element + B(1) = cos(branch_angle) !angle between parent & element + + if(elem_cnct(1,0,ne_parent).eq.0)then ! is the first child branch + B(2) = cos(pi/2.0_dp - branch_angle) !angle btwn normal & element + else !for second child + B(2) = cos(pi/2.0_dp + branch_angle) !angle btwn normal & element + endif + B(3) = 0.0_dp !on plane:(w-p).nrml=const;nrml.p=const - elem_field(ne_length,ne) = length(i) - elem_field(ne_radius,ne) = radius(i) - elem_field(ne_a_A,ne) = a_A(i) - elem_field(ne_vol,ne) = PI*radius(i)**2*length(i) + direction = mesh_a_x_eq_b(A,B) !solve ax=b + direction = unit_vector(direction) + endif + do n = 1,n_refine + + np0 = elem_nodes(2,ne0) + + ne_global = ne_global + 1 ! new global element number + ne = ne + 1 ! new local element number + np_global = np_global + 1 !new global node number + np = np + 1 ! new local node number + + nodes(np) = np_global + elems(ne) = ne_global + + elem_nodes(1,ne) = np0 + elem_nodes(2,ne) = np + + elem_ordrs(no_gen,ne) = ngen_parent + 1 !generation(i) + elem_ordrs(no_type,ne) = ntype ! 0 for respiratory, 1 for conducting + + if(n.eq.1)then + elem_symmetry(ne) = symmetry_temp(i)+1 ! uses 0/1 in file; 1/2 in code + else + elem_symmetry(ne) = 1 !not symmetric if a refined branch + endif + + ! record the element connectivity + elem_cnct(-1,0,ne) = 1 ! one parent branch + elem_cnct(-1,1,ne) = ne0 ! store parent element + elem_cnct(1,0,ne0) = elem_cnct(1,0,ne0) + 1 + elem_cnct(1,elem_cnct(1,0,ne0),ne0) = ne + + ! record the direction and location of the branch + do j=1,3 + elem_direction(j,ne) = direction(j) !!! WAS parent_direction(j) + node_xyz(j,np) = node_xyz(j,np0) + & + elem_direction(j,ne)*length(i)/dble(n_refine) + enddo !j + + elem_field(ne_length,ne) = length(i)/dble(n_refine) + elem_field(ne_radius,ne) = radius(i) + elem_field(ne_a_A,ne) = a_A(i) + + elem_field(ne_vol,ne) = pi*radius(i)**2 * length(i)/dble(n_refine) + + ne0 = ne + enddo !n enddo !i + + if(scale_to_unit)then + allocate(volume_below(ne)) + volume_below = 0.0_dp +!!! scale the mesh branch sizes such that total volume is the same as the unit volume + ! elements in unit are from ne_start+1 to ne + volume_below(ne_start+1:ne) = elem_field(ne_vol,ne_start+1:ne) ! initialise + do ne_u = ne,ne_start+1,-1 + ne_u0 = elem_cnct(-1,1,ne_u) + volume_below(ne_u0) = volume_below(ne_u0) & + + dble(elem_symmetry(ne_u))*volume_below(ne_u) + enddo + nunit = where_inlist(ne_parent0,units) + ratio = unit_field(nu_vol,nunit)/volume_below(ne_parent0) + elem_field(ne_vol,ne_start+1:ne) = elem_field(ne_vol,ne_start+1:ne)*ratio + +!!! scale the length and radius by the cube root of volume ratio + do ne_u = ne_start+1,ne ! scale both the length and the radius + elem_field(ne_radius,ne_u) = elem_field(ne_radius,ne_u)*ratio**0.333_dp + elem_field(ne_length,ne_u) = elem_field(ne_length,ne_u)*ratio**0.333_dp + enddo +!!! move the nodes to match the length scaling + do ne_u = ne_start,ne + np1 = elem_nodes(1,ne_u) + np2 = elem_nodes(2,ne_u) + node_xyz(:,np2) = node_xyz(:,np1) + elem_field(ne_length,ne_u) * & + elem_direction(:,ne_u) + enddo + + deallocate(volume_below) + endif + enddo !nunit num_nodes = np num_elems = ne - + call element_connectivity_1d - call evaluate_ordering ! calculate new ordering of tree - - call enter_exit(sub_name,2) + + deallocate(parentlist) end subroutine add_mesh + !!!############################################################################# @@ -432,7 +541,7 @@ subroutine append_units() elem_units_below(ne0) = elem_units_below(ne0) & + elem_units_below(ne)*elem_symmetry(ne) enddo !ne - + call enter_exit(sub_name,2) end subroutine append_units @@ -2660,11 +2769,12 @@ subroutine define_rad_from_geom(ORDER_SYSTEM, CONTROL_PARAM, START_FROM, & elem_field(ne_radius,ne) = USER_RAD endif n_max_ord=elem_ordrs(nindex,ne) - + do ne=ne_min,ne_max radius = 10.0_dp**(log10(CONTROL_PARAM)*dble(elem_ordrs(nindex,ne) & -n_max_ord)+log10(USER_RAD)) elem_field(ne_radius,ne)=radius + if(ne_vol.gt.0)then elem_field(ne_vol,ne) = pi*radius**2*elem_field(ne_length,ne) endif @@ -2674,7 +2784,7 @@ subroutine define_rad_from_geom(ORDER_SYSTEM, CONTROL_PARAM, START_FROM, & endif enddo endif - + call enter_exit(sub_name,2) end subroutine define_rad_from_geom @@ -3454,6 +3564,32 @@ subroutine get_local_node(np_global,np_local) end subroutine get_local_node +!!!############################################################################# + + function get_parent_branch(ne) + ! gets the elements number of the first proximal element that is a + ! different generation number to the current elements + + integer,intent(in) :: ne + + integer :: ne_gen,ne_temp,ne_temp_gen + integer :: get_parent_branch + + ne_gen = elem_ordrs(1,ne) !generation of element + if(ne_gen.eq.1)then ! can't have a grandparent + get_parent_branch = 0 + else + ne_temp = elem_cnct(-1,1,ne) + ne_temp_gen = elem_ordrs(1,ne_temp) + do while(ne_gen.eq.ne_temp_gen) + ne_temp = elem_cnct(-1,1,ne_temp) + ne_temp_gen = elem_ordrs(1,ne_temp) + enddo + get_parent_branch = ne_temp + endif + + end function get_parent_branch + !!!############################################################################# subroutine geo_entry_exit_cap(element_spline,ifile,ncount_loop, & @@ -4286,6 +4422,20 @@ function get_local_elem_1d(ne_global) end function get_local_elem_1d +!!!############################################################################# + + function where_inlist(item,ilist) + + integer :: item,ilist(:) + integer :: n + integer :: where_inlist + + do n=1,size(ilist) + if(item == ilist(n)) where_inlist = n + enddo + + end function where_inlist + !!!########################################################################### subroutine write_elem_geometry_2d(elemfile) diff --git a/src/lib/mesh_utilities.f90 b/src/lib/mesh_utilities.f90 index 5fa24dd0..78ff4b06 100644 --- a/src/lib/mesh_utilities.f90 +++ b/src/lib/mesh_utilities.f90 @@ -25,6 +25,7 @@ module mesh_utilities calc_branch_direction, & calc_scale_factors_2d, & check_colinear_points, & + check_vectors_same, & cross_product,& direction_point_to_point, & distance_between_points, & @@ -644,6 +645,29 @@ function check_colinear_points(POINT1,POINT2,POINT3) end function check_colinear_points +!!!############################################################### + + function check_vectors_same(vector1, vector2) + + ! check whether two vectors have the same direction + + real(dp) :: vector1(3),vector2(3) + + real(dp) :: norm_v1(3),norm_v2(3),u(3),v(3) + logical :: check_vectors_same + + check_vectors_same = .false. + norm_v1 = unit_vector(vector1) + norm_v2 = unit_vector(vector2) + u(1:3) = norm_v1(1:3) - norm_v2(1:3) + v(1:3) = norm_v1(1:3) + norm_v2(1:3) + + if((abs(u(1))+abs(u(2))+abs(u(3)).lt.zero_tol).or. & + (abs(v(1))+abs(v(2))+abs(v(3)).lt.zero_tol)) & + check_vectors_same = .true. + + end function check_vectors_same + !!!############################################################### function cross_product(A,B) diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index 026c8da8..51d7185a 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -86,6 +86,7 @@ subroutine evaluate_vent sub_name = 'evaluate_vent' call enter_exit(sub_name,1) + write(*,*) elem_ordrs(1:4,1),no_type !!! Initialise variables: pmus_factor_in = 1.0_dp From bf69622856056eff9237e5f72e9e74a929cd2ea1 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 16 Jul 2021 13:41:24 +1200 Subject: [PATCH 06/25] removed write statement in add_mesh --- src/lib/geometry.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 371f7c18..22f8bd88 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -126,8 +126,7 @@ subroutine add_mesh(meshfile, branchtype, n_refine) elseif(index(branchtype, "RESP")>0 .or. index(branchtype, "resp")>0)then ntype = 0 endif - write(*,*) ntype ! = 1 - read(*,*) + ! ios is negative if an end of record condition is encountered or if ! an endfile condition was detected. It is positive if an error was ! detected. ios is zero otherwise. From 9113eb6024ededc9ab6acbc2f59e0db5e6cfcdc7 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Sun, 18 Jul 2021 12:03:18 +1200 Subject: [PATCH 07/25] starting to move ventilation parameters out of files --- src/bindings/c/geometry.c | 6 +++--- src/bindings/c/geometry.f90 | 12 ++++++------ src/bindings/c/geometry.h | 2 +- src/lib/arrays.f90 | 27 ++++++++++++++++++++++----- src/lib/exports.f90 | 10 +++++++++- src/lib/geometry.f90 | 14 ++++++++------ src/lib/ventilation.f90 | 26 +++++++++++++------------- 7 files changed, 62 insertions(+), 35 deletions(-) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index 07a2a8de..335b28e3 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -24,7 +24,7 @@ void element_connectivity_1d_c(void); void evaluate_ordering_c(void); void refine_1d_elements_c(int *elemlist_len, int elemlist[], int *nrefinements); void renumber_tree_in_order_c(void); -void set_initial_volume_c(int *Gdirn, double *COV, double *total_volume, double *Rmax, double *Rmin); +void initialise_lung_volume_c(int *Gdirn, double *COV, double *total_volume, double *Rmax, double *Rmin); void volume_of_mesh_c(double *volume_model, double *volume_tree); void write_elem_geometry_2d_c(const char *ELEMFILE, int *filename_len); void write_geo_file_c(int *ntype, const char *GEOFILE, int *filename_len); @@ -146,9 +146,9 @@ void renumber_tree_in_order() renumber_tree_in_order_c(); } -void set_initial_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin) +void initialise_lung_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin) { - set_initial_volume_c(&Gdirn, &COV, &total_volume, &Rmax, &Rmin); + initialise_lung_volume_c(&Gdirn, &COV, &total_volume, &Rmax, &Rmin); } void volume_of_mesh(double *volume_model, double *volume_tree) diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index a352df73..047255bf 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -419,12 +419,12 @@ end subroutine renumber_tree_in_order_c !################################################################################### ! -!>*set_initial_volume:* assigns a volume to terminal units appended on a tree structure +!>*initialise_lung_volume:* assigns a volume to terminal units appended on a tree structure !>based on an assumption of a linear gradient in the gravitational direction with max !> min and COV values defined. - subroutine set_initial_volume_c(Gdirn, COV, total_volume, Rmax, Rmin) bind(C, name="set_initial_volume_c") + subroutine initialise_lung_volume_c(Gdirn, COV, total_volume, Rmax, Rmin) bind(C, name="initialise_lung_volume_c") - use geometry, only: set_initial_volume + use geometry, only: initialise_lung_volume use arrays, only: dp implicit none @@ -433,12 +433,12 @@ subroutine set_initial_volume_c(Gdirn, COV, total_volume, Rmax, Rmin) bind(C, na real(dp),intent(in) :: COV, total_volume, Rmax, Rmin #if defined _WIN32 && defined __INTEL_COMPILER - call so_set_initial_volume(Gdirn, COV, total_volume, Rmax, Rmin) + call so_initialise_lung_volume(Gdirn, COV, total_volume, Rmax, Rmin) #else - call set_initial_volume(Gdirn, COV, total_volume, Rmax, Rmin) + call initialise_lung_volume(Gdirn, COV, total_volume, Rmax, Rmin) #endif - end subroutine set_initial_volume_c + end subroutine initialise_lung_volume_c ! !################################################################################### diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index 776ca358..630b7ab8 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -24,7 +24,7 @@ SHO_PUBLIC void element_connectivity_1d(); SHO_PUBLIC void evaluate_ordering(); SHO_PUBLIC void refine_1d_elements(int elemlist_len, int elemlist[], int nrefinements); SHO_PUBLIC void renumber_tree_in_order(); -SHO_PUBLIC void set_initial_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin); +SHO_PUBLIC void initialise_lung_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin); SHO_PUBLIC void volume_of_mesh(double *volume_model, double *volume_tree); SHO_PUBLIC void write_elem_geometry_2d(const char *ELEMFILE); SHO_PUBLIC void write_geo_file(int ntype, const char *GEOFILE); diff --git a/src/lib/arrays.f90 b/src/lib/arrays.f90 index d9070cd6..32853a63 100644 --- a/src/lib/arrays.f90 +++ b/src/lib/arrays.f90 @@ -102,11 +102,28 @@ module arrays end type elasticity_param type fluid_properties - real(dp) :: blood_viscosity=0.33600e-02_dp !Pa.s - real(dp) :: blood_density=0.10500e-02_dp !kg/cm3 - real(dp) :: air_viscosity - real(dp) :: air_density + real(dp) :: blood_viscosity=0.33600e-02_dp !Pa.s + real(dp) :: blood_density=0.10500e-02_dp !kg/cm3 + real(dp) :: air_viscosity = 1.8e-5_dp ! Pa.s + real(dp) :: air_density = 1.146e-6_dp ! g.mm^-3 end type fluid_properties + + type lung_mechanics + ! default values for Fung exponential, as per Tawhai et al (2009) + real(dp) :: a = 0.433_dp + real(dp) :: b = -0.611_dp + real(dp) :: c = 2500.0_dp + real(dp) :: refvol_ratio = 0.5_dp + real(dp) :: chest_wall_compliance = 2000.0_dp + end type lung_mechanics + + type lung_volumes + ! default values for the 'typical' upright lung + real(dp) :: frc = 3.0e+6_dp ! frc in mm3 + real(dp) :: Rmax = 0.79_dp ! ratio of density in non-dependent tissue to mean density + real(dp) :: Rmin = 1.29_dp ! ratio of density in dependent tissue to mean density + real(dp) :: COV = 0.1_dp ! coefficient of variation for density + end type lung_volumes ! temporary, for debugging: real(dp) :: unit_before @@ -121,7 +138,7 @@ module arrays num_lines_2d, lines_2d, line_versn_2d, lines_in_elem, nodes_in_line, elems_2d, & elem_cnct_2d, elem_nodes_2d, elem_versn_2d, elem_lines_2d, elems_at_node_2d, arclength, & scale_factors_2d, parentlist, fluid_properties, elasticity_vessels, admittance_param, & - elasticity_param, all_admit_param + elasticity_param, all_admit_param, lung_mechanics, lung_volumes contains subroutine set_node_field_value(row, col, value) diff --git a/src/lib/exports.f90 b/src/lib/exports.f90 index 3f3333ea..576d08f6 100644 --- a/src/lib/exports.f90 +++ b/src/lib/exports.f90 @@ -639,11 +639,19 @@ subroutine export_terminal_solution(EXNODEFILE, name) !!! Local Variables integer :: len_end,ne,nj,NOLIST,np,np_last,VALUE_INDEX + character(len=300) :: writefile logical :: FIRST_NODE + if(index(EXNODEFILE, ".exnode")> 0) then !full filename is given + writefile = EXNODEFILE + else ! need to append the correct filename extension + writefile = trim(EXNODEFILE)//'.exnode' + endif + len_end=len_trim(name) + if(num_units.GT.0) THEN - open(10, file=EXNODEFILE, status='replace') + open(10, file=writefile, status='replace') !** write the group name write(10,'( '' Group name: '',A)') name(:len_end) FIRST_NODE=.TRUE. diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 22f8bd88..f97aab84 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -48,7 +48,7 @@ module geometry public reallocate_node_elem_arrays public refine_1d_elements public renumber_tree_in_order - public set_initial_volume + public initialise_lung_volume public triangles_from_surface public volume_of_mesh public write_geo_file @@ -214,6 +214,8 @@ subroutine add_mesh(meshfile, branchtype, n_refine) ! for the branching angle and direction - if(symmetry_temp(i).eq.1)then ! same as parent if symmetric direction(:) = elem_direction(:,ne_parent) + elseif(nbranch.eq.1)then + direction(:) = elem_direction(:,ne_parent) else ne_grandparent = get_parent_branch(ne_parent) dirn_parent(:) = elem_direction(:,ne_parent) @@ -3240,11 +3242,11 @@ end subroutine evaluate_ordering !!!############################################################################# - subroutine set_initial_volume(Gdirn,COV,total_volume,Rmax,Rmin) - !*set_initial_volume:* assigns a volume to terminal units appended on a + subroutine initialise_lung_volume(Gdirn,COV,total_volume,Rmax,Rmin) + !*initialise_lung_volume:* assigns a volume to terminal units appended on a ! tree structure based on an assumption of a linear gradient in the ! gravitational direction with max, min, and COV values defined. - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_SET_INITIAL_VOLUME" :: SET_INITIAL_VOLUME + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIALISE_LUNG_VOLUME" :: INITIALISE_LUNG_VOLUME integer,intent(in) :: Gdirn real(dp),intent(in) :: COV,total_volume,Rmax,Rmin @@ -3256,7 +3258,7 @@ subroutine set_initial_volume(Gdirn,COV,total_volume,Rmax,Rmin) ! -------------------------------------------------------------------------- - sub_name = 'set_initial_volume' + sub_name = 'initialise_lung_volume' call enter_exit(sub_name,1) volume_estimate = 1.0_dp @@ -3307,7 +3309,7 @@ subroutine set_initial_volume(Gdirn,COV,total_volume,Rmax,Rmin) call enter_exit(sub_name,2) - end subroutine set_initial_volume + end subroutine initialise_lung_volume !!!############################################################################# diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index 51d7185a..431bcb24 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -34,8 +34,8 @@ module ventilation real(dp),parameter,private :: gravity = 9.81e3_dp ! mm/s2 !!! for air - real(dp),parameter,private :: gas_density = 1.146e-6_dp ! g.mm^-3 - real(dp),parameter,private :: gas_viscosity = 1.8e-5_dp ! Pa.s + !real(dp),parameter,private :: gas_density = 1.146e-6_dp ! g.mm^-3 + !real(dp),parameter,private :: gas_viscosity = 1.8e-5_dp ! Pa.s contains @@ -86,7 +86,6 @@ subroutine evaluate_vent sub_name = 'evaluate_vent' call enter_exit(sub_name,1) - write(*,*) elem_ordrs(1:4,1),no_type !!! Initialise variables: pmus_factor_in = 1.0_dp @@ -118,7 +117,7 @@ subroutine evaluate_vent call volume_of_mesh(init_vol,volume_tree) !!! distribute the initial tissue unit volumes along the gravitational axis. - call set_initial_volume(gdirn,COV,FRC*1.0e+6_dp,RMaxMean,RMinMean) + call initialise_lung_volume(gdirn,COV,FRC*1.0e+6_dp,RMaxMean,RMinMean) undef = refvol * (FRC*1.0e+6_dp-volume_tree)/dble(elem_units_below(1)) !!! calculate the total model volume @@ -534,7 +533,7 @@ subroutine tissue_compliance(chest_wall_compliance,undef) real(dp), intent(in) :: chest_wall_compliance,undef ! Local variables integer :: ne,nunit - real(dp),parameter :: a = 0.433_dp, b = -0.611_dp, cc = 2500.0_dp + type(lung_mechanics) :: mechanics real(dp) :: exp_term,lambda,ratio character(len=60) :: sub_name @@ -550,17 +549,17 @@ subroutine tissue_compliance(chest_wall_compliance,undef) !calculate a compliance for the tissue unit ratio = unit_field(nu_vol,nunit)/undef lambda = ratio**(1.0_dp/3.0_dp) !uniform extension ratio - exp_term = exp(0.75_dp*(3.0_dp*a+b)*(lambda**2-1.0_dp)**2) + exp_term = exp(0.75_dp*(3.0_dp*mechanics%a+mechanics%b)*(lambda**2.0_dp-1.0_dp)**2.0_dp) - unit_field(nu_comp,nunit) = cc*exp_term/6.0_dp*(3.0_dp*(3.0_dp*a+b)**2 & - *(lambda**2-1.0_dp)**2/lambda**2+(3.0_dp*a+b) & - *(lambda**2+1.0_dp)/lambda**4) + unit_field(nu_comp,nunit) = mechanics%c*exp_term/6.0_dp*(3.0_dp*(3.0_dp*mechanics%a+mechanics%b)**2.0_dp & + *(lambda**2.0_dp-1.0_dp)**2.0_dp/lambda**2.0_dp+(3.0_dp*mechanics%a+mechanics%b) & + *(lambda**2.0_dp+1.0_dp)/lambda**4.0_dp) unit_field(nu_comp,nunit) = undef/unit_field(nu_comp,nunit) ! V/P ! add the chest wall (proportionately) in parallel unit_field(nu_comp,nunit) = 1.0_dp/(1.0_dp/unit_field(nu_comp,nunit)& +1.0_dp/(chest_wall_compliance/dble(num_units))) !estimate an elastic recoil pressure for the unit - unit_field(nu_pe,nunit) = cc/2.0_dp*(3.0_dp*a+b)*(lambda**2.0_dp & + unit_field(nu_pe,nunit) = mechanics%c/2.0_dp*(3.0_dp*mechanics%a+mechanics%b)*(lambda**2.0_dp & -1.0_dp)*exp_term/lambda enddo !nunit @@ -672,6 +671,7 @@ end subroutine update_elem_field subroutine update_resistance + type(fluid_properties) :: fluid_param ! Local variables integer :: i,ne,ne2,np1,np2,nunit real(dp) :: ett_resistance,gamma,le,rad,resistance,reynolds,sum,zeta @@ -700,15 +700,15 @@ subroutine update_resistance rad = elem_field(ne_radius,ne) ! element Poiseuille (laminar) resistance in units of Pa.s.mm-3 - resistance = 8.0_dp*GAS_VISCOSITY*elem_field(ne_length,ne)/ & + resistance = 8.0_dp*fluid_param%air_viscosity*elem_field(ne_length,ne)/ & (PI*elem_field(ne_radius,ne)**4) !laminar resistance ! element turbulent resistance (flow in bifurcating tubes) gamma = 0.357_dp !inspiration if(elem_field(ne_Vdot,ne).lt.0.0_dp) gamma = 0.46_dp !expiration - reynolds = abs(elem_field(ne_Vdot,ne)*2.0_dp*GAS_DENSITY/ & - (pi*elem_field(ne_radius,ne)*GAS_VISCOSITY)) + reynolds = abs(elem_field(ne_Vdot,ne)*2.0_dp*fluid_param%air_density/ & + (pi*elem_field(ne_radius,ne)*fluid_param%air_viscosity)) zeta = MAX(1.0_dp,dsqrt(2.0_dp*elem_field(ne_radius,ne)* & reynolds/elem_field(ne_length,ne))*gamma) elem_field(ne_resist,ne) = resistance * zeta From a2606dbef463664dcb74b3d690ea59f6b636e066 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Sun, 18 Jul 2021 20:22:22 +1200 Subject: [PATCH 08/25] setting up default parameters for ventilation model --- src/bindings/c/arrays.c | 9 + src/bindings/c/arrays.f90 | 23 +- src/bindings/c/arrays.h | 1 + src/bindings/c/ventilation.c | 6 +- src/bindings/c/ventilation.f90 | 10 +- src/bindings/c/ventilation.h | 2 +- src/lib/arrays.f90 | 87 +++++++- src/lib/geometry.f90 | 9 +- src/lib/ventilation.f90 | 376 +++++++-------------------------- 9 files changed, 213 insertions(+), 310 deletions(-) diff --git a/src/bindings/c/arrays.c b/src/bindings/c/arrays.c index e64c8f72..a9d3cc4a 100644 --- a/src/bindings/c/arrays.c +++ b/src/bindings/c/arrays.c @@ -1,9 +1,18 @@ #include "arrays.h" +#include "string.h" void set_node_field_value_c(int *row, int *col, double *value); +void update_parameter_c(const char *parameter_name, int *parameter_name_len, double *parameter_value); void set_node_field_value(int row, int col, double value) { set_node_field_value_c(&row, &col, &value); } + +void update_parameter(const char *parameter_name, double parameter_value) +{ + int parameter_name_len = (int)strlen(parameter_name); + update_parameter_c(parameter_name, ¶meter_name_len, ¶meter_value); +} + diff --git a/src/bindings/c/arrays.f90 b/src/bindings/c/arrays.f90 index 45790b5d..384146a6 100644 --- a/src/bindings/c/arrays.f90 +++ b/src/bindings/c/arrays.f90 @@ -12,7 +12,7 @@ module arrays_c use arrays,only: dp implicit none - public set_node_field_value_c + public set_node_field_value_c,update_parameter_c contains subroutine set_node_field_value_c(row, col, value) bind(C, name="set_node_field_value_c") @@ -30,5 +30,26 @@ subroutine set_node_field_value_c(row, col, value) bind(C, name="set_node_field_ end subroutine set_node_field_value_c + subroutine update_parameter_c(parameter_name, parameter_name_len, parameter_value) bind(C, name="update_parameter_c") + use iso_c_binding, only: c_ptr + use utils_c, only: strncpy + use other_consts, only: max_filename_len + use arrays, only: update_parameter + implicit none + + integer, intent(in) :: parameter_name_len + real(dp), intent(in) :: parameter_value + type(c_ptr),value, intent(in) :: parameter_name + character(len=max_filename_len) :: parameter_name_f + + call strncpy(parameter_name_f, parameter_name, parameter_name_len) +#if defined _WIN32 && defined __INTEL_COMPILER + call so_update_parameter(parameter_name_f, parameter_value) +#else + call update_parameter(parameter_name_f, parameter_value) +#endif + end subroutine update_parameter_c + + end module arrays_c diff --git a/src/bindings/c/arrays.h b/src/bindings/c/arrays.h index 1468b841..15495724 100644 --- a/src/bindings/c/arrays.h +++ b/src/bindings/c/arrays.h @@ -5,5 +5,6 @@ #include "symbol_export.h" SHO_PUBLIC void set_node_field_value(int row, int col, double value); +SHO_PUBLIC void update_parameter(const char *parameter_name, double parameter_value); #endif /* AETHER_ARRAYS_H */ diff --git a/src/bindings/c/ventilation.c b/src/bindings/c/ventilation.c index 2d113075..d37755d9 100644 --- a/src/bindings/c/ventilation.c +++ b/src/bindings/c/ventilation.c @@ -1,13 +1,13 @@ #include "ventilation.h" -void evaluate_vent_c(); +void evaluate_vent_c(int *num_breaths, double *dt); void evaluate_uniform_flow_c(); void two_unit_test_c(); -void evaluate_vent() +void evaluate_vent(int num_breaths, double dt) { - evaluate_vent_c(); + evaluate_vent_c(&num_breaths, &dt); } void evaluate_uniform_flow() diff --git a/src/bindings/c/ventilation.f90 b/src/bindings/c/ventilation.f90 index 1c9bc126..01ef95d8 100644 --- a/src/bindings/c/ventilation.f90 +++ b/src/bindings/c/ventilation.f90 @@ -6,15 +6,19 @@ module ventilation_c !!!################################################################################### - subroutine evaluate_vent_c() bind(C, name="evaluate_vent_c") + subroutine evaluate_vent_c(num_breaths, dt) bind(C, name="evaluate_vent_c") + use arrays,only: dp use ventilation, only: evaluate_vent implicit none + integer, intent(in) :: num_breaths + real(dp), intent(in) :: dt + #if defined _WIN32 && defined __INTEL_COMPILER - call so_evaluate_vent + call so_evaluate_vent(num_breaths, dt) #else - call evaluate_vent + call evaluate_vent(num_breaths, dt) #endif end subroutine evaluate_vent_c diff --git a/src/bindings/c/ventilation.h b/src/bindings/c/ventilation.h index 68f101c3..db7ad285 100644 --- a/src/bindings/c/ventilation.h +++ b/src/bindings/c/ventilation.h @@ -3,7 +3,7 @@ #include "symbol_export.h" -SHO_PUBLIC void evaluate_vent(); +SHO_PUBLIC void evaluate_vent(int num_breaths, double dt); SHO_PUBLIC void evaluate_uniform_flow(); SHO_PUBLIC void two_unit_test(); diff --git a/src/lib/arrays.f90 b/src/lib/arrays.f90 index 32853a63..7a59449b 100644 --- a/src/lib/arrays.f90 +++ b/src/lib/arrays.f90 @@ -108,22 +108,46 @@ module arrays real(dp) :: air_density = 1.146e-6_dp ! g.mm^-3 end type fluid_properties - type lung_mechanics + type default_lung_mechanics ! default values for Fung exponential, as per Tawhai et al (2009) real(dp) :: a = 0.433_dp real(dp) :: b = -0.611_dp real(dp) :: c = 2500.0_dp real(dp) :: refvol_ratio = 0.5_dp real(dp) :: chest_wall_compliance = 2000.0_dp - end type lung_mechanics + end type default_lung_mechanics - type lung_volumes + type default_lung_volumes ! default values for the 'typical' upright lung real(dp) :: frc = 3.0e+6_dp ! frc in mm3 real(dp) :: Rmax = 0.79_dp ! ratio of density in non-dependent tissue to mean density real(dp) :: Rmin = 1.29_dp ! ratio of density in dependent tissue to mean density real(dp) :: COV = 0.1_dp ! coefficient of variation for density - end type lung_volumes + end type default_lung_volumes + + type default_ventilation + ! default values for ventilation + real(dp) :: tidal_volume = 4.0e+5_dp ! mm^3 + real(dp) :: i_to_e_ratio = 1.0_dp ! dim. + real(dp) :: time_breath = 4.0_dp ! sec + real(dp) :: P_air_inlet = 0.0_dp ! Pa + real(dp) :: P_muscle_estimate = -98.0665_dp * 2.0_dp ! 2 cmH2O converted to Pa + real(dp) :: factor_P_muscle_insp = 1.0_dp ! multiplier to scale inspiratory pressure + real(dp) :: factor_P_muscle_expn = 1.0_dp ! multiplier to scale expiratory pressure + character(len=7) :: expiration_type = 'active' ! or passive + end type default_ventilation + + type default_ventilation_solver + ! default values for the iterative solution in ventilation code + integer :: num_iterations = 200 + real(dp) :: error_tolerance = 1.0e-08_dp + end type default_ventilation_solver + +!!! arrays that start with default values, updated during simulations + type(default_lung_mechanics) :: lung_mechanics + type(default_lung_volumes) :: lung_volumes + type(default_ventilation) :: ventilation_values + type(default_ventilation_solver) :: ventilation_solver ! temporary, for debugging: real(dp) :: unit_before @@ -138,7 +162,8 @@ module arrays num_lines_2d, lines_2d, line_versn_2d, lines_in_elem, nodes_in_line, elems_2d, & elem_cnct_2d, elem_nodes_2d, elem_versn_2d, elem_lines_2d, elems_at_node_2d, arclength, & scale_factors_2d, parentlist, fluid_properties, elasticity_vessels, admittance_param, & - elasticity_param, all_admit_param, lung_mechanics, lung_volumes + elasticity_param, all_admit_param, lung_mechanics, lung_volumes, ventilation_values, & + ventilation_solver, update_parameter contains subroutine set_node_field_value(row, col, value) @@ -152,5 +177,57 @@ subroutine set_node_field_value(row, col, value) end subroutine set_node_field_value + subroutine update_parameter(parameter_name, parameter_value) + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_UPDATE_PARAMETER" :: UPDATE_PARAMETER + implicit none + real(dp), intent(in) :: parameter_value + character(len=*), intent(in) :: parameter_name + + select case(parameter_name) + +!!! lung_volumes + case('COV') + lung_volumes%COV = parameter_value + case('FRC') + lung_volumes%FRC = parameter_value + case('Rmax') + lung_volumes%Rmax = parameter_value + case('Rmin') + lung_volumes%Rmin = parameter_value + +!!! lung_mechanics + case('chest_wall_compliance') + lung_mechanics%chest_wall_compliance = parameter_value + case('mech_a') + lung_mechanics%a = parameter_value + case('mech_b') + lung_mechanics%b = parameter_value + case('mech_c') + lung_mechanics%c = parameter_value + case('refvol_ratio') + lung_mechanics%refvol_ratio = parameter_value + +!!! ventilation_values + case('i_to_e_ratio') + ventilation_values%i_to_e_ratio = parameter_value + case('tidal_volume') + ventilation_values%tidal_volume = parameter_value + case('time_breath') + ventilation_values%time_breath = parameter_value + case('P_muscle_estimate') + ventilation_values%P_muscle_estimate = parameter_value + case('P_air_inlet') + ventilation_values%P_air_inlet = parameter_value + +!!! ventilation_solver + case('vent_error_tol') + ventilation_solver%error_tolerance = parameter_value + case('vent_num_iterations') + ventilation_solver%num_iterations = int(parameter_value) + + end select + + end subroutine update_parameter + end module arrays diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index f97aab84..dd8f5de4 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -3251,6 +3251,7 @@ subroutine initialise_lung_volume(Gdirn,COV,total_volume,Rmax,Rmin) integer,intent(in) :: Gdirn real(dp),intent(in) :: COV,total_volume,Rmax,Rmin ! Local parameters + !type(lung_volumes) :: volumes ! has the default values, and is updated to use in other modules integer :: ne,np2,nunit real(dp) :: factor_adjust,max_z,min_z,random_number,range_z,& volume_estimate,volume_of_tree,Vmax,Vmin,Xi @@ -3260,7 +3261,13 @@ subroutine initialise_lung_volume(Gdirn,COV,total_volume,Rmax,Rmin) sub_name = 'initialise_lung_volume' call enter_exit(sub_name,1) - + + ! update the default parameters + lung_volumes%frc = total_volume + lung_volumes%Rmax = Rmax + lung_volumes%Rmin = Rmin + lung_volumes%COV = COV + volume_estimate = 1.0_dp volume_of_tree = 0.0_dp diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index 431bcb24..b4d189bb 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -33,51 +33,31 @@ module ventilation public sum_elem_field_from_periphery real(dp),parameter,private :: gravity = 9.81e3_dp ! mm/s2 -!!! for air - !real(dp),parameter,private :: gas_density = 1.146e-6_dp ! g.mm^-3 - !real(dp),parameter,private :: gas_viscosity = 1.8e-5_dp ! Pa.s contains !!!############################################################################# - subroutine evaluate_vent + subroutine evaluate_vent(num_breaths, dt) !*evaluate_vent:* Sets up and solves dynamic ventilation model !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_EVALUATE_VENT" :: EVALUATE_VENT + integer, intent(in) :: num_breaths + real(dp), intent(in) :: dt ! Local variables - integer :: gdirn ! 1(x), 2(y), 3(z); upright lung (for our - ! models) is z, supine is y. - integer :: iter_step,n,ne,num_brths,num_itns,nunit + integer :: iter_step,n,ne,nunit real(dp) :: chestwall_restvol ! resting volume of chest wall - real(dp) :: chest_wall_compliance ! constant compliance of chest wall - real(dp) :: constrict ! for applying uniform constriction - real(dp) :: COV ! COV of tissue compliance - real(dp) :: i_to_e_ratio ! ratio inspiration to expiration time real(dp) :: p_mus ! muscle (driving) pressure - real(dp) :: pmus_factor_ex ! pmus_factor (_in and _ex) used to scale - real(dp) :: pmus_factor_in ! modifies driving pressures to converge - ! tidal volume and expired volume to the - ! target volume. - real(dp) :: pmus_step ! change in Ppl for driving flow (Pa) - real(dp) :: press_in ! constant pressure at entry to model (Pa) - real(dp) :: press_in_total ! dynamic pressure at entry to model (Pa) - real(dp) :: refvol ! proportion of model for 'zero stress' - real(dp) :: RMaxMean ! ratio max to mean volume - real(dp) :: RMinMean ! ratio min to mean volume real(dp) :: sum_expid ! sum of expired volume (mm^3) real(dp) :: sum_tidal ! sum of inspired volume (mm^3) real(dp) :: Texpn ! time for expiration (s) - real(dp) :: T_interval ! the total length of the breath (s) real(dp) :: Tinsp ! time for inspiration (s) real(dp) :: undef ! the zero stress volume. undef < RV - real(dp) :: volume_target ! the target tidal volume (mm^3) - real(dp) :: dpmus,dt,endtime,err_est,err_tol,FRC,init_vol,last_vol, & + real(dp) :: dpmus,endtime,err_est,FRC,init_vol,last_vol, & current_vol,Pcw,ppl_current,pptrans,prev_flow,ptrans_frc, & sum_dpmus,sum_dpmus_ei,time,totalc,Tpass,ttime,volume_tree,WOBe,WOBr, & WOBe_insp,WOBr_insp,WOB_insp - character :: expiration_type*(10) ! active (sine wave), passive, pressure logical :: CONTINUE,converged character(len=60) :: sub_name @@ -88,82 +68,65 @@ subroutine evaluate_vent call enter_exit(sub_name,1) !!! Initialise variables: - pmus_factor_in = 1.0_dp - pmus_factor_ex = 1.0_dp time = 0.0_dp !initialise the simulation time. n = 0 !initialise the 'breath number'. incremented at start of each breath. sum_tidal = 0.0_dp ! initialise the inspired and expired volumes sum_expid = 0.0_dp last_vol = 0.0_dp -!!! set default values for the parameters that control the breathing simulation -!!! these should be controlled by user input (showing hard-coded for now) - - call read_params_evaluate_flow(gdirn, chest_wall_compliance, & - constrict, COV, FRC, i_to_e_ratio, pmus_step, press_in,& - refvol, RMaxMean, RMinMean, T_interval, volume_target, expiration_type) - call read_params_main(num_brths, num_itns, dt, err_tol) - -!!! set dynamic pressure at entry. only changes for the 'pressure' option - press_in_total = press_in - !!! calculate key variables from the boundary conditions/problem parameters - Texpn = T_interval / (1.0_dp+i_to_e_ratio) - Tinsp = T_interval - Texpn + Texpn = ventilation_values%time_breath / (1.0_dp+ventilation_values%i_to_e_ratio) + Tinsp = ventilation_values%time_breath - Texpn !!! store initial branch lengths, radii, resistance etc. in array 'elem_field' call update_elem_field(1.0_dp) call update_resistance call volume_of_mesh(init_vol,volume_tree) -!!! distribute the initial tissue unit volumes along the gravitational axis. - call initialise_lung_volume(gdirn,COV,FRC*1.0e+6_dp,RMaxMean,RMinMean) - undef = refvol * (FRC*1.0e+6_dp-volume_tree)/dble(elem_units_below(1)) + undef = lung_mechanics%refvol_ratio * (lung_volumes%FRC-volume_tree)/dble(elem_units_below(1)) !!! calculate the total model volume call volume_of_mesh(init_vol,volume_tree) - write(*,'('' Anatomical deadspace = '',F8.3,'' ml'')') & - volume_tree/1.0e+3_dp ! in mL - write(*,'('' Respiratory volume = '',F8.3,'' L'')') & - (init_vol-volume_tree)/1.0e+6_dp !in L - write(*,'('' Total lung volume = '',F8.3,'' L'')') & - init_vol/1.0e+6_dp !in L + write(*,'('' Anatomical deadspace = '',F8.3,'' ml'')') volume_tree/1.0e+3_dp ! in mL + write(*,'('' Respiratory volume = '',F8.3,'' L'')') (init_vol-volume_tree)/1.0e+6_dp !in L + write(*,'('' Total lung volume = '',F8.3,'' L'')') init_vol/1.0e+6_dp !in L unit_field(nu_dpdt,1:num_units) = 0.0_dp !!! calculate the compliance of each tissue unit - call tissue_compliance(chest_wall_compliance,undef) + call tissue_compliance(undef) totalc = SUM(unit_field(nu_comp,1:num_units)) !the total model compliance call update_pleural_pressure(ppl_current) !calculate new pleural pressure pptrans=SUM(unit_field(nu_pe,1:num_units))/num_units - chestwall_restvol = init_vol + chest_wall_compliance * (-ppl_current) - Pcw = (chestwall_restvol - init_vol)/chest_wall_compliance + chestwall_restvol = init_vol + lung_mechanics%chest_wall_compliance * (-ppl_current) + Pcw = (chestwall_restvol - init_vol)/lung_mechanics%chest_wall_compliance write(*,'('' Chest wall RV = '',F8.3,'' L'')') chestwall_restvol/1.0e+6_dp - call write_flow_step_results(chest_wall_compliance,init_vol, & + call write_flow_step_results(init_vol, & current_vol,ppl_current,pptrans,Pcw,p_mus,0.0_dp,0.0_dp) continue = .true. do while (continue) n = n + 1 ! increment the breath number ttime = 0.0_dp ! each breath starts with ttime=0 - endtime = T_interval * n - 0.5_dp * dt ! the end time of this breath + endtime = ventilation_values%time_breath * dble(n) - 0.5_dp * dt ! the end time of this breath p_mus = 0.0_dp ptrans_frc = SUM(unit_field(nu_pe,1:num_units))/num_units !ptrans at frc if(n.gt.1)then !write out 'end of breath' information - call write_end_of_breath(init_vol,current_vol,pmus_factor_in, & - pmus_step,sum_expid,sum_tidal,volume_target,WOBe_insp, & + call write_end_of_breath(init_vol,current_vol,sum_expid,sum_tidal,WOBe_insp, & WOBr_insp,WOB_insp) - if(abs(volume_target).gt.1.0e-5_dp)THEN + if(abs(ventilation_values%tidal_volume).gt.1.0e-5_dp)THEN ! modify driving muscle pressure by volume_target/sum_tidal ! this increases p_mus for volume_target>sum_tidal, and ! decreases p_mus for volume_target mm^3/Pa) - - open(fh, file='Parameters/params_evaluate_flow.txt') - - ! ios is negative if an end of record condition is encountered or if - ! an endfile condition was detected. It is positive if an error was - ! detected. ios is zero otherwise. - - do while (ios == 0) - read(fh, '(A)', iostat=ios) buffer - if (ios == 0) then - line = line + 1 - - ! Find the first instance of whitespace. Split label and data. - pos = scan(buffer, ' ') - label = buffer(1:pos) - buffer = buffer(pos+1:) - - select case (label) - case ('FRC') - read(buffer, *, iostat=ios) FRC - print *, 'Read FRC: ', FRC - case ('constrict') - read(buffer, *, iostat=ios) constrict - print *, 'Read constrict: ', constrict - case ('T_interval') - read(buffer, *, iostat=ios) T_interval - print *, 'Read T_interval: ', T_interval - case ('Gdirn') - read(buffer, *, iostat=ios) gdirn - print *, 'Read Gdirn: ', gdirn - case ('press_in') - read(buffer, *, iostat=ios) press_in - print *, 'Read press_in: ', press_in - case ('COV') - read(buffer, *, iostat=ios) COV - print *, 'Read COV: ', COV - case ('RMaxMean') - read(buffer, *, iostat=ios) RMaxMean - print *, 'Read RMaxMean: ', RMaxMean - case ('RMinMean') - read(buffer, *, iostat=ios) RMinMean - print *, 'Read RMinMean: ', RMinMean - case ('i_to_e_ratio') - read(buffer, *, iostat=ios) i_to_e_ratio - print *, 'Read i_to_e_ratio: ', i_to_e_ratio - case ('refvol') - read(buffer, *, iostat=ios) refvol - print *, 'Read refvol: ', refvol - case ('volume_target') - read(buffer, *, iostat=ios) volume_target - print *, 'Read volume_target: ', volume_target - case ('pmus_step') - read(buffer, *, iostat=ios) pmus_step - print *, 'Read pmus_step_coeff: ', pmus_step - case ('expiration_type') - read(buffer, *, iostat=ios) expiration_type - print *, 'Read expiration_type: ', expiration_type - case ('chest_wall_compliance') - read(buffer, *, iostat=ios) chest_wall_compliance - print *, 'Read chest_wall_compliance: ', chest_wall_compliance - case default - print *, 'Skipping invalid label at line', line - end select - end if - end do - - close(fh) - call enter_exit(sub_name,2) - - end subroutine read_params_evaluate_flow - !!!############################################################################# subroutine two_unit_test @@ -1113,11 +897,11 @@ end subroutine two_unit_test !!!############################################################################# - subroutine write_end_of_breath(init_vol,current_vol,pmus_factor_in, & - pmus_step,sum_expid,sum_tidal,volume_target,WOBe_insp,WOBr_insp,WOB_insp) + subroutine write_end_of_breath(init_vol,current_vol, & + sum_expid,sum_tidal,WOBe_insp,WOBr_insp,WOB_insp) - real(dp),intent(in) :: init_vol,current_vol,pmus_factor_in,pmus_step, & - sum_expid,sum_tidal,volume_target,WOBe_insp,WOBr_insp,WOB_insp + real(dp),intent(in) :: init_vol,current_vol, & + sum_expid,sum_tidal,WOBe_insp,WOBr_insp,WOB_insp ! Local variables character(len=60) :: sub_name @@ -1131,11 +915,11 @@ subroutine write_end_of_breath(init_vol,current_vol,pmus_factor_in, & write(*,'('' End of breath, expired = '',F10.2,'' L'')') & sum_expid/1.0e+6_dp write(*,'('' Peak muscle pressure = '',F10.2,'' cmH2O'')') & - pmus_step*pmus_factor_in/98.0665_dp + ventilation_values%P_muscle_estimate*ventilation_values%factor_P_muscle_insp/98.0665_dp write(*,'('' Drift in FRC from start = '',F10.2,'' %'')') & - 100*(current_vol-init_vol)/init_vol + 100.0_dp*(current_vol-init_vol)/init_vol write(*,'('' Difference from target Vt = '',F8.2,'' %'')') & - 100*(volume_target-sum_tidal)/volume_target + 100.0_dp*(ventilation_values%tidal_volume-sum_tidal)/ventilation_values%tidal_volume write(*,'('' Total Work of Breathing ='',F7.3,''J/min'')')WOB_insp write(*,'('' elastic WOB ='',F7.3,''J/min'')')WOBe_insp write(*,'('' resistive WOB='',F7.3,''J/min'')')WOBr_insp @@ -1146,10 +930,10 @@ end subroutine write_end_of_breath !!!############################################################################# - subroutine write_flow_step_results(chest_wall_compliance,init_vol, & + subroutine write_flow_step_results(init_vol, & current_vol,ppl_current,pptrans,Pcw,p_mus,time,ttime) - real(dp),intent(in) :: chest_wall_compliance,init_vol,current_vol, & + real(dp),intent(in) :: init_vol,current_vol, & ppl_current,pptrans,Pcw,p_mus,time,ttime ! Local variables real(dp) :: totalC,Precoil @@ -1162,7 +946,7 @@ subroutine write_flow_step_results(chest_wall_compliance,init_vol, & !the total model compliance totalC = 1.0_dp/(1.0_dp/sum(unit_field(nu_comp,1:num_units))+ & - 1.0_dp/chest_wall_compliance) + 1.0_dp/lung_mechanics%chest_wall_compliance) Precoil = sum(unit_field(nu_pe,1:num_units))/num_units if(abs(time).lt.zero_tol)then @@ -1206,21 +990,21 @@ end subroutine write_flow_step_results !!!############################################################################# - function ventilation_continue(n,num_brths,sum_tidal,volume_target) + function ventilation_continue(n,num_breaths,sum_tidal) - integer,intent(in) :: n,num_brths - real(dp),intent(in) :: sum_tidal,volume_target + integer,intent(in) :: n,num_breaths + real(dp),intent(in) :: sum_tidal ! Local variables logical :: ventilation_continue ! -------------------------------------------------------------------------- ventilation_continue = .true. - if(n.ge.num_brths)then + if(n.ge.num_breaths)then ventilation_continue = .false. - elseif(abs(volume_target).gt.1.0e-3_dp)then - if(abs(100.0_dp*(volume_target-sum_tidal) & - /volume_target).gt.0.1_dp.or.(n.lt.2))then + elseif(abs(ventilation_values%tidal_volume).gt.1.0e-3_dp)then + if(abs(100.0_dp*(ventilation_values%tidal_volume-sum_tidal) & + /ventilation_values%tidal_volume).gt.0.1_dp.or.(n.lt.2))then ventilation_continue = .true. else ventilation_continue = .false. From 711a7202e0f37d02afe8c6ce5ce9870be6794103 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Sun, 18 Jul 2021 21:19:43 +1200 Subject: [PATCH 09/25] removing the chest wall compliance from tissue compliance calculation --- src/lib/ventilation.f90 | 84 ++++++++++++++++++----------------------- 1 file changed, 37 insertions(+), 47 deletions(-) diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index b4d189bb..6c77e6c3 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -47,17 +47,16 @@ subroutine evaluate_vent(num_breaths, dt) ! Local variables integer :: iter_step,n,ne,nunit real(dp) :: chestwall_restvol ! resting volume of chest wall - real(dp) :: p_mus ! muscle (driving) pressure + real(dp) :: P_muscle ! muscle (driving) pressure real(dp) :: sum_expid ! sum of expired volume (mm^3) real(dp) :: sum_tidal ! sum of inspired volume (mm^3) real(dp) :: Texpn ! time for expiration (s) real(dp) :: Tinsp ! time for inspiration (s) real(dp) :: undef ! the zero stress volume. undef < RV - real(dp) :: dpmus,endtime,err_est,FRC,init_vol,last_vol, & + real(dp) :: dP_muscle,endtime,err_est,init_vol,last_vol, & current_vol,Pcw,ppl_current,pptrans,prev_flow,ptrans_frc, & - sum_dpmus,sum_dpmus_ei,time,totalc,Tpass,ttime,volume_tree,WOBe,WOBr, & - WOBe_insp,WOBr_insp,WOB_insp + time,ttime,volume_tree,WOBe,WOBr,WOBe_insp,WOBr_insp,WOB_insp logical :: CONTINUE,converged character(len=60) :: sub_name @@ -96,7 +95,6 @@ subroutine evaluate_vent(num_breaths, dt) !!! calculate the compliance of each tissue unit call tissue_compliance(undef) - totalc = SUM(unit_field(nu_comp,1:num_units)) !the total model compliance call update_pleural_pressure(ppl_current) !calculate new pleural pressure pptrans=SUM(unit_field(nu_pe,1:num_units))/num_units @@ -105,14 +103,14 @@ subroutine evaluate_vent(num_breaths, dt) write(*,'('' Chest wall RV = '',F8.3,'' L'')') chestwall_restvol/1.0e+6_dp call write_flow_step_results(init_vol, & - current_vol,ppl_current,pptrans,Pcw,p_mus,0.0_dp,0.0_dp) + current_vol,ppl_current,pptrans,Pcw,P_muscle,0.0_dp,0.0_dp) continue = .true. do while (continue) n = n + 1 ! increment the breath number ttime = 0.0_dp ! each breath starts with ttime=0 endtime = ventilation_values%time_breath * dble(n) - 0.5_dp * dt ! the end time of this breath - p_mus = 0.0_dp + P_muscle = 0.0_dp ptrans_frc = SUM(unit_field(nu_pe,1:num_units))/num_units !ptrans at frc if(n.gt.1)then !write out 'end of breath' information @@ -121,8 +119,8 @@ subroutine evaluate_vent(num_breaths, dt) if(abs(ventilation_values%tidal_volume).gt.1.0e-5_dp)THEN ! modify driving muscle pressure by volume_target/sum_tidal - ! this increases p_mus for volume_target>sum_tidal, and - ! decreases p_mus for volume_targetsum_tidal, and + ! decreases P_muscle for volume_target Date: Mon, 19 Jul 2021 11:34:01 +1200 Subject: [PATCH 10/25] writing ventilation output to file --- src/lib/ventilation.f90 | 52 ++++++++++++++++++++++++++++++++--------- 1 file changed, 41 insertions(+), 11 deletions(-) diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index 6c77e6c3..fbf9b3d9 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -58,13 +58,16 @@ subroutine evaluate_vent(num_breaths, dt) current_vol,Pcw,ppl_current,pptrans,prev_flow,ptrans_frc, & time,ttime,volume_tree,WOBe,WOBr,WOBe_insp,WOBr_insp,WOB_insp logical :: CONTINUE,converged - + character(len=60) :: filename = 'ventilation.opvent' + character(len=60) :: sub_name ! -------------------------------------------------------------------------- sub_name = 'evaluate_vent' call enter_exit(sub_name,1) + + open(10, file=filename, status='replace') !!! Initialise variables: time = 0.0_dp !initialise the simulation time. @@ -171,6 +174,8 @@ subroutine evaluate_vent(num_breaths, dt) elem_field(ne_Vdot,1:num_elems) = & elem_field(ne_Vdot,1:num_elems)/elem_field(ne_Vdot,1) + close(10) + call enter_exit(sub_name,2) end subroutine evaluate_vent @@ -314,7 +319,7 @@ subroutine set_driving_pressures(dP_muscle,dt,P_muscle,Texpn,Tinsp,ttime) Tinsp,ttime real(dp) :: dP_muscle,P_muscle ! Local variables - real(dp) :: sum_dP_muscle,sum_dP_muscle_ei,Tpass + real(dp) :: mu character(len=60) :: sub_name ! -------------------------------------------------------------------------- @@ -333,23 +338,26 @@ subroutine set_driving_pressures(dP_muscle,dt,P_muscle,Texpn,Tinsp,ttime) sin(2.0_dp*pi*(0.5_dp+(ttime-Tinsp)/(2.0_dp*Texpn)))/ & (2.0_dp*Texpn)*dt endif + P_muscle = P_muscle + dP_muscle !current value for muscle pressure case('passive') if(ttime.le.Tinsp+0.5_dp*dt)then - dP_muscle = ventilation_values%P_muscle_estimate*ventilation_values%factor_P_muscle_insp*PI*dt* & - sin(pi*ttime/Tinsp)/(2.0_dp*Tinsp) - sum_dP_muscle = sum_dP_muscle+dP_muscle - sum_dP_muscle_ei = sum_dP_muscle + dP_muscle = ventilation_values%P_muscle_estimate*ventilation_values%factor_P_muscle_insp*PI* & + sin(pi*ttime/Tinsp)/(2.0_dp*Tinsp)*dt +! sum_dP_muscle = sum_dP_muscle+dP_muscle +! sum_dP_muscle_ei = sum_dP_muscle + P_muscle = P_muscle + dP_muscle !current value for muscle pressure +! P_muscle_peak = P_muscle else - Tpass = 0.1_dp - dP_muscle = MIN(-sum_dP_muscle_ei/(Tpass*Texpn)*dt,-sum_dP_muscle) - sum_dP_muscle = sum_dP_muscle+dP_muscle +!!! the following rate of reduction of inspiratory muscle pressure during expiration +!!! is consistent with data from Baydur, JAP 72(2):712-720, 1992 +! mu = -0.5_dp/(log(1.2_dp*98.0665_dp/P_muscle_peak)) +! P_muscle = P_muscle_peak * exp(-(ttime-Tinsp)/mu) endif +! P_total = ventilation_values%P_air_inlet + (P_chestwall - P_recoil) + P_muscle end select - P_muscle = P_muscle + dP_muscle !current value for muscle pressure - call enter_exit(sub_name,2) end subroutine set_driving_pressures @@ -958,6 +966,16 @@ subroutine write_flow_step_results(init_vol, & 0.0_dp, & !Pmuscle (cmH2O) Pcw/98.0665_dp, & !Pchest_wall (cmH2O) (-Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) + write(10,'(F7.3,2(F8.1),8(F8.2))') & + 0.0_dp,0.0_dp,0.0_dp, & !time, flow, tidal + elem_field(ne_t_resist,1)*1.0e+6_dp/98.0665_dp, & !res (cmH2O/L.s) + totalC*98.0665_dp/1.0e+6_dp, & !total model compliance + ppl_current/98.0665_dp, & !Ppl (cmH2O) + -ppl_current/98.0665_dp, & !mean Ptp (cmH2O) + init_vol/1.0e+6_dp, & !total model volume (L) + 0.0_dp, & !Pmuscle (cmH2O) + Pcw/98.0665_dp, & !Pchest_wall (cmH2O) + (-Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) else write(*,'(F7.3,2(F8.1),8(F8.2))') & time, & !time through breath (s) @@ -971,6 +989,18 @@ subroutine write_flow_step_results(init_vol, & P_muscle/98.0665_dp, & !Pmuscle (cmH2O) -Pcw/98.0665_dp, & !Pchest_wall (cmH2O) (P_muscle+Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) + write(10,'(F7.3,2(F8.1),8(F8.2))') & + time, & !time through breath (s) + elem_field(ne_Vdot,1)/1.0e+3_dp, & !flow at the inlet (mL/s) + (current_vol - init_vol)/1.0e+3_dp, & !current tidal volume (mL) + elem_field(ne_t_resist,1)*1.0e+6_dp/98.0665_dp, & !res (cmH2O/L.s) + totalC*98.0665_dp/1.0e+6_dp, & !total model compliance + ppl_current/98.0665_dp, & !Ppl (cmH2O) + pptrans/98.0665_dp, & !mean Ptp (cmH2O) + current_vol/1.0e+6_dp, & !total model volume (L) + P_muscle/98.0665_dp, & !Pmuscle (cmH2O) + -Pcw/98.0665_dp, & !Pchest_wall (cmH2O) + (P_muscle+Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) endif From 41e61ce884c8941a5d539c24f64d68813d586ac6 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Tue, 20 Jul 2021 17:37:52 +1200 Subject: [PATCH 11/25] muscle pressure functions for passive expiration --- src/lib/arrays.f90 | 2 +- src/lib/ventilation.f90 | 103 +++++++++++++++++++++------------------- 2 files changed, 56 insertions(+), 49 deletions(-) diff --git a/src/lib/arrays.f90 b/src/lib/arrays.f90 index 7a59449b..ab96b811 100644 --- a/src/lib/arrays.f90 +++ b/src/lib/arrays.f90 @@ -134,7 +134,7 @@ module arrays real(dp) :: P_muscle_estimate = -98.0665_dp * 2.0_dp ! 2 cmH2O converted to Pa real(dp) :: factor_P_muscle_insp = 1.0_dp ! multiplier to scale inspiratory pressure real(dp) :: factor_P_muscle_expn = 1.0_dp ! multiplier to scale expiratory pressure - character(len=7) :: expiration_type = 'active' ! or passive + character(len=7) :: expiration_type = 'passive' end type default_ventilation type default_ventilation_solver diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index fbf9b3d9..4be8111b 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -55,7 +55,8 @@ subroutine evaluate_vent(num_breaths, dt) real(dp) :: undef ! the zero stress volume. undef < RV real(dp) :: dP_muscle,endtime,err_est,init_vol,last_vol, & - current_vol,Pcw,ppl_current,pptrans,prev_flow,ptrans_frc, & + current_vol,Pcw,P_muscle_peak,ppl_current,P_recoil,P_residual, & + P_transp,prev_flow,ptrans_frc, & time,ttime,volume_tree,WOBe,WOBr,WOBe_insp,WOBr_insp,WOB_insp logical :: CONTINUE,converged character(len=60) :: filename = 'ventilation.opvent' @@ -89,6 +90,7 @@ subroutine evaluate_vent(num_breaths, dt) !!! calculate the total model volume call volume_of_mesh(init_vol,volume_tree) + current_vol = init_vol write(*,'('' Anatomical deadspace = '',F8.3,'' ml'')') volume_tree/1.0e+3_dp ! in mL write(*,'('' Respiratory volume = '',F8.3,'' L'')') (init_vol-volume_tree)/1.0e+6_dp !in L @@ -99,14 +101,15 @@ subroutine evaluate_vent(num_breaths, dt) !!! calculate the compliance of each tissue unit call tissue_compliance(undef) call update_pleural_pressure(ppl_current) !calculate new pleural pressure - pptrans=SUM(unit_field(nu_pe,1:num_units))/num_units + P_transp=SUM(unit_field(nu_pe,1:num_units))/num_units + P_recoil = P_transp + P_residual = 0.0_dp chestwall_restvol = init_vol + lung_mechanics%chest_wall_compliance * (-ppl_current) Pcw = (chestwall_restvol - init_vol)/lung_mechanics%chest_wall_compliance write(*,'('' Chest wall RV = '',F8.3,'' L'')') chestwall_restvol/1.0e+6_dp - call write_flow_step_results(init_vol, & - current_vol,ppl_current,pptrans,Pcw,P_muscle,0.0_dp,0.0_dp) + call write_flow_step_results(init_vol,current_vol,ppl_current,P_transp,Pcw,P_muscle,0.0_dp,0.0_dp) continue = .true. do while (continue) @@ -139,18 +142,17 @@ subroutine evaluate_vent(num_breaths, dt) ttime = ttime + dt ! increment the breath time time = time + dt ! increment the whole simulation time !!!.......calculate the flow and pressure distribution for one time-step - call evaluate_vent_step( & - chestwall_restvol,dt,init_vol,last_vol,current_vol, & - Pcw,P_muscle,ppl_current, & - pptrans,prev_flow,ptrans_frc, & + call evaluate_vent_step(chestwall_restvol,dt,init_vol,last_vol,current_vol, & + Pcw,P_muscle,P_muscle_peak,ppl_current,P_recoil,P_residual,P_transp,prev_flow,ptrans_frc, & sum_expid,sum_tidal,texpn,time,tinsp,ttime,undef,WOBe,WOBr, & WOBe_insp,WOBr_insp,WOB_insp, & dP_muscle,converged,iter_step) !!!.......update the estimate of pleural pressure call update_pleural_pressure(ppl_current) ! new pleural pressure + P_recoil = SUM(unit_field(nu_pe,1:num_units))/num_units call write_flow_step_results(init_vol, & - current_vol,ppl_current,pptrans,Pcw,P_muscle,time,ttime) + current_vol,ppl_current,P_transp,Pcw,P_muscle,time,ttime) enddo !while time Date: Fri, 20 Aug 2021 08:58:49 +1200 Subject: [PATCH 12/25] in refine_1d_elements, included call to renumber_tree_in_order so that this is done automatically. we always need an ordered tree --- src/lib/geometry.f90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index dd8f5de4..3b7e8240 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -3839,6 +3839,7 @@ subroutine refine_1d_elements(elem_list_refine,num_refinements) deallocate(node_list) call element_connectivity_1d elem_ordrs(no_type,:) = 1 ! 0 for respiratory, 1 for conducting + call renumber_tree_in_order end subroutine refine_1d_elements From e1345dd2b388655132ae0653321b66196b67f213 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 20 Aug 2021 10:20:12 +1200 Subject: [PATCH 13/25] bindings for initial_gasexchange and steadystate_gasexchange, and replaced dabs with abs in gas_exchange.f90 --- src/bindings/c/gas_exchange.c | 16 +++++++++--- src/bindings/c/gas_exchange.f90 | 17 +++++++++++++ src/bindings/c/gas_exchange.h | 4 ++- src/bindings/interface/gas_exchange.i | 5 ++++ src/lib/gas_exchange.f90 | 36 +++++++++++++-------------- 5 files changed, 55 insertions(+), 23 deletions(-) diff --git a/src/bindings/c/gas_exchange.c b/src/bindings/c/gas_exchange.c index 0ccc549c..364c38eb 100644 --- a/src/bindings/c/gas_exchange.c +++ b/src/bindings/c/gas_exchange.c @@ -1,14 +1,22 @@ #include "gas_exchange.h" +void initial_gasexchange_c(double *initial_concentration, double *surface_area, double *V_cap); + void steadystate_gasexchange_c(double *c_art_o2, double *c_ven_o2, double *p_art_co2, double *p_art_o2, double *p_i_o2, double *p_ven_co2, double *p_ven_o2, double *shunt_fraction, double *VCO2, double *VO2); -void steadystate_gasexchange(double *c_art_o2, double *c_ven_o2, - double *p_art_co2, double *p_art_o2, double *p_i_o2, double *p_ven_co2, double *p_ven_o2, double *shunt_fraction, - double *VCO2, double *VO2) + +void initial_gasexchange(double initial_concentration, double surface_area, double V_cap) +{ + initial_gasexchange_c(&initial_concentration, &surface_area, &V_cap); +} + +void steadystate_gasexchange(double c_art_o2, double c_ven_o2, double p_art_co2, double p_art_o2, + double p_i_o2, double p_ven_co2, double p_ven_o2, double shunt_fraction, + double VCO2, double VO2) { - steadystate_gasexchange_c(c_art_o2, c_ven_o2, p_art_co2, p_art_o2, p_i_o2, p_ven_co2, p_ven_o2, shunt_fraction, VCO2, VO2); + steadystate_gasexchange_c(&c_art_o2, &c_ven_o2, &p_art_co2, &p_art_o2, &p_i_o2, &p_ven_co2, &p_ven_o2, &shunt_fraction, &VCO2, &VO2); } diff --git a/src/bindings/c/gas_exchange.f90 b/src/bindings/c/gas_exchange.f90 index 5bb6f8f7..3e3abd40 100644 --- a/src/bindings/c/gas_exchange.f90 +++ b/src/bindings/c/gas_exchange.f90 @@ -4,6 +4,23 @@ module gas_exchange_c contains !!!###################################################################### + subroutine initial_gasexchange_c(initial_concentration,surface_area,V_cap) & + bind(C, name="initial_gasexchange_c") + use gas_exchange,only: initial_gasexchange + use arrays,only: dp + implicit none + !!! Parameter List + real(dp),intent(in) :: initial_concentration,surface_area,V_cap + +#if defined _WIN32 && defined __INTEL_COMPILER + call so_initial_gasexchange(initial_concentration,surface_area,V_cap) +#else + call initial_gasexchange(initial_concentration,surface_area,V_cap) +#endif + + end subroutine initial_gasexchange_c + +!!!###################################################################### subroutine steadystate_gasexchange_c(c_art_o2,c_ven_o2,& p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& VCO2,VO2) bind(C, name="steadystate_gasexchange_c") diff --git a/src/bindings/c/gas_exchange.h b/src/bindings/c/gas_exchange.h index c727b417..ea1a66c3 100644 --- a/src/bindings/c/gas_exchange.h +++ b/src/bindings/c/gas_exchange.h @@ -3,6 +3,8 @@ #include "symbol_export.h" -SHO_PUBLIC void steadystate_gasexchange(); +SHO_PUBLIC void initial_gasexchange(double initial_concentration, double surface_area, double V_cap); +SHO_PUBLIC void steadystate_gasexchange(double c_art_o2, double c_ven_o2, double p_art_co2, double p_art_o2, + double p_i_o2, double p_ven_co2, double p_ven_o2, double shunt_fraction, double VCO2, double VO2); #endif /* AETHER_GAS_EXCHANGE_H */ diff --git a/src/bindings/interface/gas_exchange.i b/src/bindings/interface/gas_exchange.i index e96e5786..b74d9356 100644 --- a/src/bindings/interface/gas_exchange.i +++ b/src/bindings/interface/gas_exchange.i @@ -7,4 +7,9 @@ #include "gas_exchange.h" %} +void initial_gasexchange(double initial_concentration, double surface_area, double V_cap); +void steadystate_gasexchange(double c_art_o2, double c_ven_o2, double p_art_co2, double p_art_o2, + double p_i_o2, double p_ven_co2, double p_ven_o2, double shunt_fraction, double VCO2, double VO2); + +%include gas_exchange.h diff --git a/src/lib/gas_exchange.f90 b/src/lib/gas_exchange.f90 index 0ea1e8d0..2575b5b8 100644 --- a/src/lib/gas_exchange.f90 +++ b/src/lib/gas_exchange.f90 @@ -166,13 +166,13 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& p_cap_co2 = gasex_field(ng_p_cap_co2,nunit) ! initialise capillary CO2 v_q = unit_field(nu_Vdot0,nunit) & /unit_field(nu_perf,nunit) ! the unit v/q - if(dabs(v_q) .le. 1.0e-3_dp)then ! no ventilation; cap CO2 == venous CO2 + if(abs(v_q) .le. 1.0e-3_dp)then ! no ventilation; cap CO2 == venous CO2 p_cap_co2 = p_ven_co2 else ! calculate the steady-state PCO2 fun_co2 = function_co2(v_q,p_cap_co2,p_ven_co2) fdash = fdash_co2(v_q,p_cap_co2) K=0 - do while(dabs(fun_co2).ge.1.0e-4_dp.and.(k.LT.200)) + do while(abs(fun_co2).ge.1.0e-4_dp.and.(k.LT.200)) K=K+1 p_cap_co2 = p_cap_co2 - fun_CO2/fdash fun_co2 = function_co2(v_q,p_cap_co2,p_ven_co2) @@ -180,8 +180,8 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& enddo endif - Q_total = Q_total + elem_units_below(ne) * dabs(unit_field(nu_perf,nunit)) !mm3/s - V_total = V_total + elem_units_below(ne) * dabs(unit_field(nu_Vdot0,nunit)) + Q_total = Q_total + elem_units_below(ne) * abs(unit_field(nu_perf,nunit)) !mm3/s + V_total = V_total + elem_units_below(ne) * abs(unit_field(nu_Vdot0,nunit)) !!! including a limitation that p_cap_co2 cannot be less than zero @@ -195,10 +195,10 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& c_cap_co2 = m*p_cap_co2/(1 + m*p_cap_co2) !!! sum the content in arterial blood (flow weighted sum) c_art_co2 = c_art_co2 + elem_units_below(ne)* & - (c_cap_co2*dabs(unit_field(nu_perf,nunit))) !flow-weighted + (c_cap_co2*abs(unit_field(nu_perf,nunit))) !flow-weighted !! sum the alveolar co2 p_alv_co2=p_alv_co2 + elem_units_below(ne)* & - (p_cap_co2*dabs(unit_field(nu_Vdot0,nunit))) !flow-weighted + (p_cap_co2*abs(unit_field(nu_Vdot0,nunit))) !flow-weighted enddo !nunit !!! update the arterial content of CO2 @@ -213,7 +213,7 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& p_art_co2 = 1/(m*(1-c_art_co2)) ! initialise p_art_co2 K=0 !counter fun_co2 = m*p_art_co2/(1+m*p_art_co2)-c_art_co2 - do while (dabs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) + do while (abs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) K=K+1 fdash=m/(1+m*p_art_co2)**2 p_art_co2 = p_art_co2 - fun_co2/fdash @@ -225,7 +225,7 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& p_ven_co2 = 1/(m*(1-target_c_ven_co2)) K=0 fun_co2=m*p_ven_co2/(1+m*p_ven_co2)-target_c_ven_CO2 - do while (dabs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) + do while (abs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) K=K+1 fdash=m/(1+m*p_ven_co2)**2 p_ven_co2 = p_ven_co2-fun_co2/fdash @@ -297,10 +297,10 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& c_cap_o2 = content_from_po2(p_cap_co2,p_cap_o2) !!! sum the content in arterial blood (flow weighted sum) c_art_o2 = c_art_o2 + elem_units_below(ne)* & - (c_cap_o2*dabs(unit_field(nu_perf,nunit))) !flow-weighted + (c_cap_o2*abs(unit_field(nu_perf,nunit))) !flow-weighted !! sum the alveolar o2 p_alv_o2=p_alv_o2 + elem_units_below(ne)* & - (p_cap_o2*dabs(unit_field(nu_Vdot0,nunit))) !flow-weighted + (p_cap_o2*abs(unit_field(nu_Vdot0,nunit))) !flow-weighted ! write(*,*) 'V/Q=',v_q,' pO2=',p_cap_o2,c_cap_o2,c_art_o2 enddo !nunit @@ -447,7 +447,7 @@ function content_from_po2 (PCO2,po2) !!! Local variables real(dp) :: content_from_po2,ShbO2 - if(dabs(po2).lt.zero_tol)then + if(abs(po2).lt.zero_tol)then SHbO2 = 0.0_dp content_from_po2 = 0.0_dp else @@ -478,7 +478,7 @@ function saturation_of_o2 (PCO2,po2) A4=9.359609e+5_dp, A5=-3.134626e+4_dp, A6=2.396167e+3_dp, A7=-6.710441e+1_dp real(dp) :: saturation_of_o2,X,ShbO2 - if(dabs(po2).lt.zero_tol)then + if(abs(po2).lt.zero_tol)then SHbO2 = 0.0_dp else @@ -505,7 +505,7 @@ function po2_from_content(c_o2,p_co2) real(dp),parameter :: tolerance=1.0e-5_dp logical :: converged - if(dabs(c_o2).lt.tolerance)then + if(abs(c_o2).lt.tolerance)then po2_from_content = 0.0_dp else converged = .false. @@ -521,18 +521,18 @@ function po2_from_content(c_o2,p_co2) do while (.not.converged.and.(i.lt.max_iterations)) ! Modify increment size if(c_o2_new.gt.c_o2)then - inc = -dabs(inc) + inc = -abs(inc) elseif(c_o2_new.lt.c_o2)then - inc = dabs(inc) + inc = abs(inc) endif if(i.gt.1)then diff_new = c_o2_new - c_o2 diff_old = c_o2_old - c_o2 - diff_step = dabs(c_o2_new-c_o2_old) + diff_step = abs(c_o2_new-c_o2_old) if((diff_old.gt.0.0_dp.and.diff_new.lt.0.0_dp).or. & (diff_old.lt.0.0_dp.and.diff_new.gt.0.0_dp))then ! the last 2 steps straddle point inc=inc/2.0_dp - elseif(dabs(diff_new).gt.diff_step)THEN + elseif(abs(diff_new).gt.diff_step)THEN inc=inc*2.0_dp endif endif @@ -543,7 +543,7 @@ function po2_from_content(c_o2,p_co2) p_o2_new = p_o2_new + inc c_o2_new = content_from_po2(p_co2,p_o2_new) ! Check convergence - if(dabs((c_o2_new-c_o2)/c_o2).LT.tolerance*c_o2) converged = .true. + if(abs((c_o2_new-c_o2)/c_o2).LT.tolerance*c_o2) converged = .true. i=i+1 From f10f2de673c5cab8e77c78d5349f6de1d1e57e70 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Sun, 22 Aug 2021 17:44:56 +1200 Subject: [PATCH 14/25] bindings and updates to make gas transfer work --- src/bindings/c/gas_exchange.c | 10 +- src/bindings/c/gas_exchange.f90 | 19 +- src/bindings/c/gas_exchange.h | 3 +- src/bindings/interface/gas_exchange.i | 3 +- src/lib/arrays.f90 | 62 ++-- src/lib/capillaryflow.f90 | 25 +- src/lib/gas_exchange.f90 | 160 ++++++++--- src/lib/indices.f90 | 32 ++- src/lib/pressure_resistance_flow.f90 | 389 +++++++++++++++++++++++--- src/lib/species_transport.f90 | 10 +- src/lib/ventilation.f90 | 7 +- src/lib/wave_transmission.f90 | 9 +- 12 files changed, 571 insertions(+), 158 deletions(-) diff --git a/src/bindings/c/gas_exchange.c b/src/bindings/c/gas_exchange.c index 364c38eb..b91b8ead 100644 --- a/src/bindings/c/gas_exchange.c +++ b/src/bindings/c/gas_exchange.c @@ -3,9 +3,7 @@ void initial_gasexchange_c(double *initial_concentration, double *surface_area, double *V_cap); -void steadystate_gasexchange_c(double *c_art_o2, double *c_ven_o2, - double *p_art_co2, double *p_art_o2, double *p_i_o2, double *p_ven_co2, double *p_ven_o2, double *shunt_fraction, - double *VCO2, double *VO2); +void steadystate_gasexchange_c(double *deadspace, double *p_i_o2, double *shunt_fraction, double *target_p_art_co2, double *target_p_ven_o2, double *VCO2, double *VO2); void initial_gasexchange(double initial_concentration, double surface_area, double V_cap) @@ -13,10 +11,8 @@ void initial_gasexchange(double initial_concentration, double surface_area, doub initial_gasexchange_c(&initial_concentration, &surface_area, &V_cap); } -void steadystate_gasexchange(double c_art_o2, double c_ven_o2, double p_art_co2, double p_art_o2, - double p_i_o2, double p_ven_co2, double p_ven_o2, double shunt_fraction, - double VCO2, double VO2) +void steadystate_gasexchange(double deadspace, double p_i_o2, double shunt_fraction, double target_p_art_co2, double target_p_ven_o2, double VCO2, double VO2) { - steadystate_gasexchange_c(&c_art_o2, &c_ven_o2, &p_art_co2, &p_art_o2, &p_i_o2, &p_ven_co2, &p_ven_o2, &shunt_fraction, &VCO2, &VO2); + steadystate_gasexchange_c(&deadspace, &p_i_o2, &shunt_fraction, &target_p_art_co2, &target_p_ven_o2, &VCO2, &VO2); } diff --git a/src/bindings/c/gas_exchange.f90 b/src/bindings/c/gas_exchange.f90 index 3e3abd40..bc32283d 100644 --- a/src/bindings/c/gas_exchange.f90 +++ b/src/bindings/c/gas_exchange.f90 @@ -21,25 +21,22 @@ subroutine initial_gasexchange_c(initial_concentration,surface_area,V_cap) & end subroutine initial_gasexchange_c !!!###################################################################### - subroutine steadystate_gasexchange_c(c_art_o2,c_ven_o2,& - p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& - VCO2,VO2) bind(C, name="steadystate_gasexchange_c") + subroutine steadystate_gasexchange_c(deadspace,p_i_o2,shunt_fraction, & + target_p_art_co2,target_p_ven_o2,VCO2,VO2) bind(C, name="steadystate_gasexchange_c") use gas_exchange, only: steadystate_gasexchange use arrays,only: dp implicit none !!! Parameter List - real(dp),intent(in) :: p_i_o2,shunt_fraction,VCO2,VO2 - real(dp), intent(inout) :: c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_ven_o2,p_ven_co2 + real(dp),intent(in) :: deadspace,p_i_o2,shunt_fraction,target_p_art_co2, & + target_p_ven_o2,VCO2,VO2 #if defined _WIN32 && defined __INTEL_COMPILER - call so_steadystate_gasexchange(c_art_o2,c_ven_o2,& - p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& - VCO2,VO2) + call so_steadystate_gasexchange(deadspace,p_i_o2,shunt_fraction, & + target_p_art_co2,target_p_ven_o2,VCO2,VO2) #else - call steadystate_gasexchange(c_art_o2,c_ven_o2,& - p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& - VCO2,VO2) + call steadystate_gasexchange(deadspace,p_i_o2,shunt_fraction, & + target_p_art_co2,target_p_ven_o2,VCO2,VO2) #endif end subroutine steadystate_gasexchange_c diff --git a/src/bindings/c/gas_exchange.h b/src/bindings/c/gas_exchange.h index ea1a66c3..4dade84f 100644 --- a/src/bindings/c/gas_exchange.h +++ b/src/bindings/c/gas_exchange.h @@ -4,7 +4,6 @@ #include "symbol_export.h" SHO_PUBLIC void initial_gasexchange(double initial_concentration, double surface_area, double V_cap); -SHO_PUBLIC void steadystate_gasexchange(double c_art_o2, double c_ven_o2, double p_art_co2, double p_art_o2, - double p_i_o2, double p_ven_co2, double p_ven_o2, double shunt_fraction, double VCO2, double VO2); +SHO_PUBLIC void steadystate_gasexchange(double deadspace, double p_i_o2, double shunt_fraction, double target_p_art_co2, double target_p_ven_o2, double VCO2, double VO2); #endif /* AETHER_GAS_EXCHANGE_H */ diff --git a/src/bindings/interface/gas_exchange.i b/src/bindings/interface/gas_exchange.i index b74d9356..1cc76582 100644 --- a/src/bindings/interface/gas_exchange.i +++ b/src/bindings/interface/gas_exchange.i @@ -8,8 +8,7 @@ %} void initial_gasexchange(double initial_concentration, double surface_area, double V_cap); -void steadystate_gasexchange(double c_art_o2, double c_ven_o2, double p_art_co2, double p_art_o2, - double p_i_o2, double p_ven_co2, double p_ven_o2, double shunt_fraction, double VCO2, double VO2); +void steadystate_gasexchange(double deadspace, double p_i_o2, double shunt_fraction, double target_p_art_co2, double target_p_ven_o2, double VCO2, double VO2); %include gas_exchange.h diff --git a/src/lib/arrays.f90 b/src/lib/arrays.f90 index ab96b811..c1c3310a 100644 --- a/src/lib/arrays.f90 +++ b/src/lib/arrays.f90 @@ -1,15 +1,15 @@ module arrays -!*Brief Description:* This module defines arrays. -! -!*LICENSE:* -! -! -!*Contributor(s):* Merryn Tawhai, Alys Clark -! -!*Full Description:* -! -!This module defines arrays - + !*Brief Description:* This module defines arrays. + ! + !*LICENSE:* + ! + ! + !*Contributor(s):* Merryn Tawhai, Alys Clark + ! + !*Full Description:* + ! + !This module defines arrays + use precision implicit none @@ -39,6 +39,19 @@ module arrays integer,allocatable :: elems_at_node_2d(:,:) integer,allocatable :: units(:) + ! from p-r-f + integer,allocatable :: mesh_from_depvar(:,:,:) + integer, allocatable :: depvar_at_node(:,:,:) + integer, allocatable :: depvar_at_elem(:,:,:) + integer, allocatable :: SparseCol(:) + integer, allocatable :: SparseRow(:) + integer, allocatable :: update_resistance_entries(:) + real(dp), allocatable :: SparseVal(:) + real(dp), allocatable :: RHS(:) + real(dp), allocatable :: prq_solution(:,:),solver_solution(:) + logical, allocatable :: FIX(:) + + real(dp),allocatable :: arclength(:,:) real(dp),allocatable :: elem_field(:,:) !properties of elements real(dp),allocatable :: elem_direction(:,:) @@ -101,12 +114,12 @@ module arrays real(dp) :: elasticity_parameters(3)=0.0_dp end type elasticity_param - type fluid_properties - real(dp) :: blood_viscosity=0.33600e-02_dp !Pa.s - real(dp) :: blood_density=0.10500e-02_dp !kg/cm3 - real(dp) :: air_viscosity = 1.8e-5_dp ! Pa.s - real(dp) :: air_density = 1.146e-6_dp ! g.mm^-3 - end type fluid_properties + type default_fluid_properties + real(dp) :: blood_viscosity = 0.33600e-02_dp ! Pa.s + real(dp) :: blood_density = 0.10500e-02_dp ! kg/cm3 + real(dp) :: air_viscosity = 1.8e-5_dp ! Pa.s + real(dp) :: air_density = 1.146e-6_dp ! g.mm^-3 + end type default_fluid_properties type default_lung_mechanics ! default values for Fung exponential, as per Tawhai et al (2009) @@ -144,6 +157,7 @@ module arrays end type default_ventilation_solver !!! arrays that start with default values, updated during simulations + type(default_fluid_properties) :: fluid_properties type(default_lung_mechanics) :: lung_mechanics type(default_lung_volumes) :: lung_volumes type(default_ventilation) :: ventilation_values @@ -163,7 +177,9 @@ module arrays elem_cnct_2d, elem_nodes_2d, elem_versn_2d, elem_lines_2d, elems_at_node_2d, arclength, & scale_factors_2d, parentlist, fluid_properties, elasticity_vessels, admittance_param, & elasticity_param, all_admit_param, lung_mechanics, lung_volumes, ventilation_values, & - ventilation_solver, update_parameter + ventilation_solver, update_parameter, & + mesh_from_depvar, depvar_at_node, depvar_at_elem, SparseCol, SparseRow, update_resistance_entries, & + SparseVal, RHS, prq_solution, solver_solution, FIX contains subroutine set_node_field_value(row, col, value) @@ -185,6 +201,16 @@ subroutine update_parameter(parameter_name, parameter_value) select case(parameter_name) +!!! fluid_properties + case('blood_viscosity') + fluid_properties%blood_viscosity = parameter_value + case('blood_density') + fluid_properties%blood_density = parameter_value + case('air_viscosity') + fluid_properties%air_viscosity = parameter_value + case('air_density') + fluid_properties%air_density = parameter_value + !!! lung_volumes case('COV') lung_volumes%COV = parameter_value diff --git a/src/lib/capillaryflow.f90 b/src/lib/capillaryflow.f90 index ed9bf583..3f37abd5 100644 --- a/src/lib/capillaryflow.f90 +++ b/src/lib/capillaryflow.f90 @@ -922,7 +922,6 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& type(elasticity_param) :: elast_param type(capillary_bf_parameters) :: cap_param - type(fluid_properties) :: fp integer :: ngen real(dp) :: alpha_c,area_scale,length_scale real(dp) :: radupdate,P_exta,P_extv,R_art1,R_ven1,R_art2,R_ven2,Q01_mthrees,Pin,Pout @@ -1157,11 +1156,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) !!!ARC TO FIX alpha_a is in m/Pa, need in 1/Pa (just read in from main model?) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fp%blood_density*(elast_param%elasticity_parameters(1))))*sqrt(1-f10)!alpha in the sense of this model is 1/Pa so has to be dovided by radius - tube_admit(gen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) + wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*(elast_param%elasticity_parameters(1))))*sqrt(1-f10)!alpha in the sense of this model is 1/Pa so has to be dovided by radius + tube_admit(gen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) prop_const(gen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed) enddo !!... FIRST HALF OF VENULE @@ -1185,11 +1184,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& Pout=Pout+R_ven1*Q01_mthrees do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fp%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s - tube_admit(gen+2*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10)!mm3/Pa.s + wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s + tube_admit(gen+2*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10)!mm3/Pa.s prop_const(gen+2*ngen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed)!1/mm enddo @@ -1228,11 +1227,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fp%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) - tube_admit(gen+ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) + wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) + tube_admit(gen+ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) prop_const(gen+ngen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed) enddo @@ -1251,11 +1250,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& Pout=Pout-R_ven2*Q01_mthrees do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fp%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s - tube_admit(gen+3*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) + wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s + tube_admit(gen+3*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) prop_const(gen+3*ngen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed) !1/mm enddo enddo diff --git a/src/lib/gas_exchange.f90 b/src/lib/gas_exchange.f90 index 2575b5b8..05ed7f47 100644 --- a/src/lib/gas_exchange.f90 +++ b/src/lib/gas_exchange.f90 @@ -65,75 +65,152 @@ module gas_exchange ! !############################################################################## ! - subroutine initial_gasexchange(initial_concentration,surface_area,V_cap) - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIAL_GASEXCHANGE" :: INITIAL_GASEXCHANGE - - !local variables - real(dp),intent(in) :: initial_concentration - real(dp), optional :: surface_area,V_cap - + subroutine initial_gasexchange(initial_concentration,surface_area,V_cap) + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIAL_GASEXCHANGE" :: INITIAL_GASEXCHANGE + + !local variables + real(dp),intent(in) :: initial_concentration + real(dp), optional :: surface_area,V_cap + integer :: nunit real(dp) :: Vcap_unit real(dp),parameter :: p_water = 47.0_dp real(dp),parameter :: press_atm=760.0_dp !atmospheric pressure, mmHg - - - character(len=60) :: sub_name - - sub_name = 'initial_gasexchange' - call enter_exit(sub_name,1) - + + + character(len=60) :: sub_name + + sub_name = 'initial_gasexchange' + call enter_exit(sub_name,1) + !!! allocate memory for the gasex_field array, if not already allocated if(.not.allocated(gasex_field)) allocate(gasex_field(num_gx,num_units)) - + !!! initialiase nj_conc2 (for CO2 concentration); currently hardcoded to 40 mmHg node_field(nj_conc2,1:num_nodes) = 40.0_dp/(o2molvol*(press_atm-p_water)) write(*,'('' Initialising Palv_CO2 to 40 mmHg'')') - + !!! initialise the gas exchange field for o2 partial pressures gasex_field(ng_p_alv_o2,1:num_units) = initial_concentration* & o2molvol*(press_atm-p_water) gasex_field(ng_p_cap_o2,1:num_units) = initial_concentration*& o2molvol*(press_atm-p_water) - + gasex_field(ng_p_alv_co2,1:num_units) = 40.0_dp ! mmHg; should make this user defined gasex_field(ng_p_ven_o2,1:num_units) = 40.0_dp ! mmHg; should make this user defined - + unit_field(nu_conc1,1:num_units) = gasex_field(ng_p_alv_o2,1:num_units)/& (o2molvol*(press_atm-p_water)) ! from mmHg to mmol/mm^3 unit_field(nu_conc2,1:num_units) = gasex_field(ng_p_alv_co2,1:num_units)/& (o2molvol*(press_atm-p_water)) ! from mmHg to mmol/mm^3 - + !!! initialise the gas exchange field for co2 partial pressures gasex_field(ng_p_alv_co2,1:num_units) = 40.0_dp ! mmHg; should make this user defined gasex_field(ng_p_cap_co2,1:num_units) = 40.0_dp ! mmHg; should make this user defined gasex_field(ng_p_ven_co2,1:num_units) = 45.0_dp ! mmHg; should make this user defined if(present(surface_area))then !!! initialise the time blood has been in capillaries - gasex_field(ng_time,1:num_units) = 0.0_dp - + gasex_field(ng_time,1:num_units) = 0.0_dp + !!! capillary volume per gas exchange unit = transit time * flow - ! elem_units_below is the EFFECTIVE number of units, so this is correct - !Note that these are calculated on a per unit basis in the perfusion model so can be read in for future iterations - Vcap_unit = V_cap/elem_units_below(1) ! the capillary volume per gas exchange unit - gasex_field(ng_Vc,1:num_units) = Vcap_unit - gasex_field(ng_sa,1:num_units) = surface_area/elem_units_below(1) - + ! elem_units_below is the EFFECTIVE number of units, so this is correct + !Note that these are calculated on a per unit basis in the perfusion model so can be read in for future iterations + Vcap_unit = V_cap/elem_units_below(1) ! the capillary volume per gas exchange unit + gasex_field(ng_Vc,1:num_units) = Vcap_unit + gasex_field(ng_sa,1:num_units) = surface_area/elem_units_below(1) + !!! transit time through the gas exchange unit = capillary volume/flow - forall (nunit=1:num_units) gasex_field(ng_tt,nunit) = & - Vcap_unit/unit_field(nu_perf,nunit) + forall (nunit=1:num_units) gasex_field(ng_tt,nunit) = & + Vcap_unit/unit_field(nu_perf,nunit) endif + + call enter_exit(sub_name,2) + end subroutine initial_gasexchange + +!!! ###################################################################### - call enter_exit(sub_name,2) - end subroutine initial_gasexchange + subroutine steadystate_gasexchange(Vdot_deadspace,p_i_o2,shunt_fraction, & + target_p_art_co2,target_p_ven_o2,VCO2,VO2) + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_STEADYSTATE_GASEXCHANGE" :: STEADYSTATE_GASEXCHANGE + + use field_utilities,only: scale_flow_to_inlet + +!!! Parameters + real(dp),intent(in) :: Vdot_deadspace,p_i_o2,shunt_fraction, & + target_p_art_co2,target_p_ven_o2,VCO2,VO2 +!!! Local variables + integer :: k,nunit + real(dp) :: cardiac_temp,c_art_o2,c_ven_o2,Vdot_alv_temp + real(dp) :: p_art_co2,p_art_o2,p_ven_co2,p_ven_o2 + character(len=60) :: sub_name + + sub_name = 'steadystate_gasexchange' + call enter_exit(sub_name,1) + + cardiac_temp = elem_field(ne_Qdot,1) + Vdot_alv_temp = elem_field(ne_Vdot,1) - Vdot_deadspace + + !temporarily scale the flow to alveolar ventilation + call scale_flow_to_inlet(Vdot_alv_temp,'V') + call steadystate_gasexchange_sub (c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_i_o2,& + p_ven_co2,p_ven_o2,shunt_fraction,VCO2,VO2) + +!!! in the following loop the alveolar ventilation is incrementally adjusted +!!! towards achieving the target p_art_co2; and the cardiac output is adjusted +!!! to balance the metabolic demand for oxygen. + k = 0 + do while (abs(p_art_co2-target_p_art_co2)/target_p_art_co2 .gt. 1.0e-4_dp ) + k = k + 1 + + Vdot_alv_temp = p_art_co2/target_p_art_co2*Vdot_alv_temp + call scale_flow_to_inlet(Vdot_alv_temp,'V') + call steadystate_gasexchange_sub (c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_i_o2,& + p_ven_co2,p_ven_o2,shunt_fraction,VCO2,VO2) + if(k.gt.200)then + write(*,'('' Exiting alveolar ventilation calculation: not converged in 200 iterations'')') + return + endif + end do + + write(*,'('' Alveolar ventilation = '',f8.3,'' L/min to match target P_art_CO2 of '',f8.3)') & + Vdot_alv_temp/1.0e+6_dp*60.0_dp,target_p_art_co2 + + k = 0 + do while (abs(p_ven_o2-target_p_ven_o2)/target_p_ven_o2 .gt. 1.0e-4_dp ) + k = k + 1 + + cardiac_temp = cardiac_temp * target_p_ven_o2/p_ven_o2 + call scale_flow_to_inlet(cardiac_temp,'Q') + call steadystate_gasexchange_sub (c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_i_o2,& + p_ven_co2,p_ven_o2,shunt_fraction,VCO2,VO2) + if(k.gt.200)then + write(*,'('' Exiting cardiac output calculation: not converged in 200 iterations'')') + return + endif + end do + if(k.le.200)then !converged +!!! update transit time through the gas exchange unit = capillary volume/flow + forall (nunit=1:num_units) gasex_field(ng_tt,nunit) = & + gasex_field(ng_Vc,nunit)/unit_field(nu_perf,nunit)/& + (cardiac_temp*(1.0_dp-shunt_fraction)) + endif + write(*,'('' Cardiac output = '',f8.3,'' L/min to match target P_ven_O2 of '',f7.2)') & + cardiac_temp/1.0e+6_dp*60.0_dp,target_p_ven_o2 + + ! scale the ventilation back to minute ventilation + Vdot_alv_temp = elem_field(ne_Vdot,1) + Vdot_deadspace + call scale_flow_to_inlet(Vdot_alv_temp,'V') + + call enter_exit(sub_name,2) + + end subroutine steadystate_gasexchange ! !########################################################################################### ! - subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& + subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& VCO2,VO2) - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_STEADYSTATE_GASEXCHANGE" :: STEADYSTATE_GASEXCHANGE !!! Parameter List real(dp),intent(in) :: p_i_o2,shunt_fraction,VCO2,VO2 @@ -149,10 +226,9 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& logical :: continue character(len=60) :: sub_name - sub_name = 'steadystate_gasexchange' + sub_name = 'steadystate_gasexchange_sub' call enter_exit(sub_name,1) - !!! Calculate steady state gas exchange for CO2 p_ven_co2_last = p_ven_co2 ! updates at each iteration, until converged counter = 1 ! count the number of iterations @@ -183,7 +259,6 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& Q_total = Q_total + elem_units_below(ne) * abs(unit_field(nu_perf,nunit)) !mm3/s V_total = V_total + elem_units_below(ne) * abs(unit_field(nu_Vdot0,nunit)) - !!! including a limitation that p_cap_co2 cannot be less than zero p_cap_co2 = max(p_cap_co2,0.0_dp) @@ -232,7 +307,7 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& fun_co2 = m*p_ven_co2/(1+m*p_ven_co2)-target_c_ven_co2 enddo !while !!! now have updated values for p_art_co2 and p_ven_co2 - write(*,'('' Interim PPs:'',4(f8.3))') p_art_o2,p_ven_o2,p_art_co2,p_ven_co2 + !write(*,'('' Interim PPs:'',4(f8.3))') p_art_o2,p_ven_o2,p_art_co2,p_ven_co2 !!! check whether p_ven_co2 and p_art_co2 have converged if(counter.gt.1)then if(abs(p_ven_co2-p_ven_co2_last)/p_ven_co2_last.lt.tol.and. & @@ -251,14 +326,13 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& endif enddo !while continue -! read(*,*) - write(*,'('' Total blood flow ='',F10.1,'' mm3/s,& - & alveolar ventilation='',F10.1,'' mm3/s'')') Q_total,V_total - write(*,'('' Steady-state P_art_CO2 ='',F6.1,'' mmHg,& + write(*,'('' Cardiac output ='',F8.3,'' L/min, alveolar ventilation ='',F8.3,'' L/min'')') & + Q_total/1.0e+6_dp*60.0_dp,V_total/1.0e+6_dp*60.0_dp + write(*,'('' Steady-state P_art_CO2 ='',F6.1,'' mmHg,& & P_ven_CO2='',F6.1,'' mmHg'')') p_art_co2,p_ven_co2 write(*,'('' P_alv_CO2 ='',F6.1,'' mmHg,& - & P(A-a)CO2='',F6.1,'' mmHg'')') p_alv_co2,p_alv_co2-p_art_co2 + & P(A-a)CO2='',F6.1,'' mmHg'')') p_alv_co2,p_alv_co2-p_art_co2 !!! Calculate steady state gas exchange for O2 p_ven_o2_last = p_ven_o2 @@ -362,7 +436,7 @@ subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& call enter_exit(sub_name,2) - end subroutine steadystate_gasexchange + end subroutine steadystate_gasexchange_sub !!! #################################################### diff --git a/src/lib/indices.f90 b/src/lib/indices.f90 index ea747393..170ddcb5 100644 --- a/src/lib/indices.f90 +++ b/src/lib/indices.f90 @@ -125,9 +125,10 @@ subroutine exchange_indices call enter_exit(sub_name,1) ! indices for elem_ordrs. These dont usually change. ! indices for node_field - num_nj=3 + num_nj=4 nj_conc1=2 nj_conc2=3 + nj_aw_press=4 !air pressure ! indices for elem_field num_ne = 11 @@ -135,21 +136,30 @@ subroutine exchange_indices ne_length = 2 ne_vol = 3 ne_resist = 4 - ne_Vdot = 5 - ne_Qdot = 6 - ne_dvdt = 7 - ne_vd_bel = 8 - ne_vol_bel = 9 + ne_t_resist = 5 + ne_Vdot = 6 !Air flow, current time step + ne_Vdot0 = 7 !air flow, last timestep + ne_dvdt = 8 + ne_vd_bel = 9 + ne_vol_bel = 10 + ne_Qdot = 11 ! indices for unit_field - num_nu=7 + num_nu=14 nu_vol=1 nu_comp=2 nu_Vdot0=3 - nu_vd=4 - nu_perf=5 - nu_conc1=6 - nu_conc2=7 + nu_Vdot1=4 + nu_Vdot2=5 + nu_dpdt=6 + nu_pe=7 + nu_vt=8 + nu_air_press=9 + nu_vent=10 + nu_vd=11 + nu_perf=12 + nu_conc1=13 + nu_conc2=14 call enter_exit(sub_name,2) diff --git a/src/lib/pressure_resistance_flow.f90 b/src/lib/pressure_resistance_flow.f90 index 073be5a3..0b590463 100644 --- a/src/lib/pressure_resistance_flow.f90 +++ b/src/lib/pressure_resistance_flow.f90 @@ -26,7 +26,7 @@ module pressure_resistance_flow !Interfaces private - public evaluate_prq,calculate_ppl + public evaluate_prq,calculate_ppl,update_prq contains !################################################################################### ! @@ -36,21 +36,21 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !local variables integer :: mesh_dof,depvar_types - integer, allocatable :: mesh_from_depvar(:,:,:) - integer, allocatable :: depvar_at_node(:,:,:) - integer, allocatable :: depvar_at_elem(:,:,:) + !integer, allocatable :: mesh_from_depvar(:,:,:) + !integer, allocatable :: depvar_at_node(:,:,:) + !integer, allocatable :: depvar_at_elem(:,:,:) integer, dimension(0:2,2) :: depvar_totals - integer, allocatable :: SparseCol(:) - integer, allocatable :: SparseRow(:) - integer, allocatable :: update_resistance_entries(:) - real(dp), allocatable :: SparseVal(:) - real(dp), allocatable :: RHS(:) + !integer, allocatable :: SparseCol(:) + !integer, allocatable :: SparseRow(:) + !integer, allocatable :: update_resistance_entries(:) + !real(dp), allocatable :: SparseVal(:) + !real(dp), allocatable :: RHS(:) integer :: num_vars,NonZeros,MatrixSize integer :: AllocateStatus - real(dp), allocatable :: prq_solution(:,:),solver_solution(:) + !real(dp), allocatable :: prq_solution(:,:),solver_solution(:) real(dp) :: viscosity,density,inlet_bc,outlet_bc,inletbc,outletbc,grav_vect(3),gamma,total_resistance,ERR - logical, allocatable :: FIX(:) + !logical, allocatable :: FIX(:) logical :: ADD=.FALSE.,CONVERGED=.FALSE. character(len=60) :: sub_name,mesh_type,vessel_type,mechanics_type,bc_type integer :: grav_dirn,no,depvar,KOUNT,nz,ne,SOLVER_FLAG,ne0,ne1,nj @@ -136,8 +136,8 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !viscosity: fluid viscosity !density:fluid density !gamma:Pedley correction factor -density=0.10500e-02_dp !kg/cm3 -viscosity=0.33600e-02_dp !Pa.s +!density=0.10500e-02_dp !kg/cm3 +!viscosity=0.33600e-02_dp !Pa.s gamma = 0.327_dp !=1.85/(4*sqrt(2)) !! Allocate memory to depvar arrays @@ -163,22 +163,22 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !! Define boundary conditions !first call to define inlet boundary conditions - call boundary_conditions(ADD,FIX,bc_type,grav_vect,density,inletbc,outletbc,& + call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) !second call if simple tree need to define pressure bcs at all terminal branches if(mesh_type.eq.'simple_tree')then ADD=.TRUE. - call boundary_conditions(ADD,FIX,bc_type,grav_vect,density,inletbc,outletbc,& + call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) elseif(mesh_type.eq.'full_plus_ladder')then ADD=.TRUE. - call boundary_conditions(ADD,FIX,bc_type,grav_vect,density,inletbc,outletbc,& + call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) endif KOUNT=0 !! Calculate resistance of each element - call calculate_resistance(viscosity,KOUNT) + call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) !! Calculate sparsity structure for solution matrices !Determine size of and allocate solution vectors/matrices @@ -197,7 +197,7 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle if (AllocateStatus /= 0) STOP "*** Not enough memory for solver_solution array ***" update_resistance_entries = 0 !calculate the sparsity structure - call calc_sparse_1dtree(bc_type,density,FIX,grav_vect,mesh_dof,depvar_at_elem, & + call calc_sparse_1dtree(bc_type,fluid_properties%blood_density,FIX,grav_vect,mesh_dof,depvar_at_elem, & depvar_at_node,NonZeros,MatrixSize,SparseCol,SparseRow,SparseVal,RHS, & prq_solution,update_resistance_entries,update_flow_nzz_row) !!! --ITERATIVE LOOP-- @@ -243,9 +243,9 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !SparseVal(nz)=-elem_field(ne_resist,ne) !Just updating resistance endif endif!first or subsequent iteration -!! ----CALL SOLVER---- + !! ----CALL SOLVER---- call pmgmres_ilu_cr(MatrixSize, NonZeros, SparseRow, SparseCol, SparseVal, & - solver_solution, RHS, 500, 500,1.d-5,1.d-4,SOLVER_FLAG) + solver_solution, RHS, 500, 500,1.d-5,1.d-4,SOLVER_FLAG) if(SOLVER_FLAG == 0)then print *, 'Warning: pmgmres has reached max iterations. Solution may not be valid if this warning persists' elseif(SOLVER_FLAG ==2)then @@ -283,11 +283,11 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle else !Update vessel radii based on predicted pressures and then update resistance through tree call calc_press_area(grav_vect,KOUNT,depvar_at_node,prq_solution,& - mesh_dof,vessel_type,elasticity_parameters,mechanics_parameters) - call calculate_resistance(viscosity,KOUNT) + mesh_dof,vessel_type,elasticity_parameters,mechanics_parameters) + call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) !Put the ladder stuff here --> See solve11.f - if(mesh_type.eq.'full_plus_ladder')then + if(mesh_type.eq.'full_plus_ladder')then do ne=1,num_elems if(elem_field(ne_group,ne).eq.1.0_dp)then!(elem_field(ne_group,ne)-1.0_dp).lt.TOLERANCE)then ne0=elem_cnct(-1,1,ne)!upstream element number @@ -310,18 +310,17 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle endif enddo endif - ERR=ERR/MatrixSize !sum of error divided by no of unknown depvar if(ERR.LE.1.d-6.AND.(KOUNT.NE.1))then CONVERGED=.TRUE. - print *,"Convergence achieved after",KOUNT,"iterations",ERR + write(*,'('' Convergence achieved after'',i4,'' iterations, error ='',e10.3)') KOUNT,ERR else !if error not converged if(ERR.GE.MIN_ERR) then N_MIN_ERR=N_MIN_ERR+1 else MIN_ERR=ERR endif - print *,"Not converged, error =",ERR + write(*,'('' Not converged, error ='',e10.3)') ERR endif !ERR not converged endif!vessel type enddo !notconverged @@ -358,18 +357,25 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle close(20) endif - deallocate (mesh_from_depvar, STAT = AllocateStatus) - deallocate (depvar_at_elem, STAT = AllocateStatus) - deallocate (depvar_at_node, STAT = AllocateStatus) - deallocate (prq_solution, STAT = AllocateStatus) - deallocate (FIX, STAT = AllocateStatus) - deallocate (solver_solution, STAT = AllocateStatus) - deallocate (SparseCol, STAT = AllocateStatus) - deallocate (SparseVal, STAT = AllocateStatus) - deallocate (SparseRow, STAT = AllocateStatus) - deallocate (RHS, STAT = AllocateStatus) - deallocate (update_resistance_entries, STAT=AllocateStatus) + !deallocate (mesh_from_depvar, STAT = AllocateStatus) + !deallocate (depvar_at_elem, STAT = AllocateStatus) + !deallocate (depvar_at_node, STAT = AllocateStatus) + !deallocate (prq_solution, STAT = AllocateStatus) + !deallocate (FIX, STAT = AllocateStatus) + !deallocate (solver_solution, STAT = AllocateStatus) + !deallocate (SparseCol, STAT = AllocateStatus) + !deallocate (SparseVal, STAT = AllocateStatus) + !deallocate (SparseRow, STAT = AllocateStatus) + !deallocate (RHS, STAT = AllocateStatus) + !deallocate (update_resistance_entries, STAT=AllocateStatus) + + write(*,'('' Cardiac output ='',f8.3,'' L/min for PAP ='',f8.3,'' mmHg and LAP ='',f8.3,'' mmHg'')') & + elem_field(ne_Qdot,1)/1.0e6_dp*60.0_dp, inletbc / 133.322_dp, outletbc / 133.322_dp + call enter_exit(sub_name,2) + + call update_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inlet_bc,outlet_bc) + end subroutine evaluate_prq ! !################################################################################### @@ -1081,6 +1087,315 @@ subroutine calculate_ppl(np,grav_vect,mechanics_parameters,Ppl) call enter_exit(sub_name,2) end subroutine calculate_ppl +! +!################################################################## +! + subroutine update_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inlet_bc,outlet_bc) + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_UPDATE_PRQ" :: UPDATE_PRQ + + !local variables + integer :: mesh_dof,depvar_types + !integer, allocatable :: mesh_from_depvar(:,:,:) + !integer, allocatable :: depvar_at_node(:,:,:) + !integer, allocatable :: depvar_at_elem(:,:,:) + integer, dimension(0:2,2) :: depvar_totals + !integer, allocatable :: SparseCol(:) + !integer, allocatable :: SparseRow(:) + !integer, allocatable :: update_resistance_entries(:) + !real(dp), allocatable :: SparseVal(:) + !real(dp), allocatable :: RHS(:) + integer :: num_vars,NonZeros,MatrixSize + integer :: AllocateStatus + + !real(dp), allocatable :: prq_solution(:,:),solver_solution(:) + real(dp) :: viscosity,density,inlet_bc,outlet_bc,inletbc,outletbc,grav_vect(3),gamma,total_resistance,ERR + !logical, allocatable :: FIX(:) + logical :: ADD=.FALSE.,CONVERGED=.FALSE. + character(len=60) :: sub_name,mesh_type,vessel_type,mechanics_type,bc_type + integer :: grav_dirn,no,depvar,KOUNT,nz,ne,SOLVER_FLAG,ne0,ne1,nj + real(dp) :: MIN_ERR,N_MIN_ERR,elasticity_parameters(3),mechanics_parameters(2),grav_factor,P1 + real(dp) :: P2,Q01,Rin,Rout,x_cap,y_cap,z_cap,Ppl,LPM_R,Lin,Lout + integer :: update_flow_nzz_row + + call enter_exit(sub_name,1) + + !!---------DESCRIPTION OF MODEL Types ----------- + !mesh_type: can be simple_tree, full_plus_ladder, full_sheet, full_tube The first can be airways, arteries, veins but no special features at the terminal level, the last one has arteries and veins connected by capillary units of some type (lung ladder acinus, lung sheet capillary bed, capillaries are just tubes represented by an element) + + !vessel_type: + !rigid, no elasticity, no parameters required + !elastic_g0_beta, R=R0*((Ptm/G0)+1.d0)^(1.d0/elasticity_parameters(2)),with an optional maximum pressure beyond which the vessel radius is constant three parameters, g0, elasticity_parameters(2), elasticity_parameters(3) + !elastic alpha, R=R0*(alpha*Ptm+1.d0), up to a limit elasticity_parameters(3) two parameters alpha, elasticity_parameters(3) + !elastic_hooke, two parameters E and h,R=R0+3.0_dp*R0**2*Ptm/(4.0_dp*E*h*R0) + + !mechanics type: + !linear two parmeters, transpulmonary pressure (average) and pleural density (gradient) + !mechanics, two parameters, pressure and stretch fields + + !bc_type: + !pressure (at inlet and outlets) + !flow (flow at inlet pressure at outlet). + + + mechanics_type='linear' + + if (vessel_type.eq.'rigid') then + elasticity_parameters=0.0_dp + elseif (vessel_type.eq.'elastic_g0_beta') then + elasticity_parameters(1)=6.67e3_dp!G0 (Pa) + elasticity_parameters(2)=1.0_dp!elasticity_parameters(2) + elasticity_parameters(3)=32.0_dp*98.07_dp !elasticity_parameters(3) (Pa) + elseif (vessel_type.eq.'elastic_alpha') then + elasticity_parameters(1)=1.503e-4_dp!alpha (1/Pa) + elasticity_parameters(2)=32.0_dp*98.07_dp !elasticity_parameters(3) (Pa) + elasticity_parameters(3)=0.0_dp !Not used + elseif (vessel_type.eq.'elastic_hooke') then + elasticity_parameters(1)=1.5e6_dp !Pa + elasticity_parameters(2)=0.1_dp!this is a fraction of the radius so is unitless + elasticity_parameters(3)=0.0_dp !Not used + else + print *, 'WARNING: Your chosen vessel type does not seem to be implemented assuming rigid' + vessel_type='rigid' + elasticity_parameters=0.0_dp + endif + + if (mechanics_type.eq.'linear') then + mechanics_parameters(1)=5.0_dp*98.07_dp !average pleural pressure (Pa) + mechanics_parameters(2)=0.25_dp*0.1e-2_dp !pleural density, defines gradient in pleural pressure + else + print *, 'ERROR: Only linear mechanics models have been implemented to date,assuming default parameters' + call exit(0) + endif + + grav_vect=0.d0 + if (grav_dirn.eq.1) then + grav_vect(1)=1.0_dp + elseif (grav_dirn.eq.2) then + grav_vect(2)=1.0_dp + elseif (grav_dirn.eq.3) then + grav_vect(3)=1.0_dp + else + print *, "ERROR: Posture not recognised (currently only x=1,y=2,z=3))" + call exit(0) + endif + grav_vect=grav_vect*grav_factor + + if(bc_type.eq.'pressure')then + inletbc=inlet_bc + outletbc=outlet_bc + elseif(bc_type.eq.'flow')then + inletbc=inlet_bc + outletbc=outlet_bc + elseif((bc_type.NE.'pressure').AND.(bc_type.NE.'flow'))then + print *,"unsupported bc_type",bc_type + call exit(1) + endif + + !!---------PHYSICAL PARAMETERS----------- + !viscosity: fluid viscosity + !density:fluid density + !gamma:Pedley correction factor + !density=0.10500e-02_dp !kg/cm3 + !viscosity=0.33600e-02_dp !Pa.s + gamma = 0.327_dp !=1.85/(4*sqrt(2)) + + mesh_dof=num_elems+num_nodes + depvar_types=2 !pressure/flow + + !! Setting up mappings between nodes, elements and solution depvar + call calc_depvar_maps(mesh_from_depvar,depvar_at_elem,& + depvar_totals,depvar_at_node,mesh_dof,num_vars) + +!! Define boundary conditions + !first call to define inlet boundary conditions + call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& + depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) + !second call if simple tree need to define pressure bcs at all terminal branches + if(mesh_type.eq.'simple_tree')then + ADD=.TRUE. + call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& + depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) + elseif(mesh_type.eq.'full_plus_ladder')then + ADD=.TRUE. + call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& + depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) + endif + + KOUNT=0 +!! Calculate resistance of each element + call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) + +!! Calculate sparsity structure for solution matrices + !Determine size of and allocate solution vectors/matrices + call calc_sparse_size(mesh_dof,depvar_at_elem,depvar_at_node,FIX,NonZeros,MatrixSize) + + !calculate the sparsity structure + call calc_sparse_1dtree(bc_type,fluid_properties%blood_density,FIX,grav_vect,mesh_dof,depvar_at_elem, & + depvar_at_node,NonZeros,MatrixSize,SparseCol,SparseRow,SparseVal,RHS, & + prq_solution,update_resistance_entries,update_flow_nzz_row) +!!! --ITERATIVE LOOP-- + MIN_ERR=1.d10 + N_MIN_ERR=0 + do while(.NOT.CONVERGED) + KOUNT=KOUNT+1 + print*, 'Outer loop iterations:',KOUNT +!!! Initialise solution vector based on bcs and rigid vessel resistance + if(KOUNT.eq.1)then!set up boundary conditions + if(bc_type.eq.'pressure')then + if(mesh_type.eq.'full_plus_ladder')then + total_resistance=1000.0_dp + else + call tree_resistance(total_resistance) + endif + call initialise_solution(inletbc,outletbc,(inletbc-outletbc)/total_resistance, & + mesh_dof,prq_solution,depvar_at_node,depvar_at_elem,FIX) + !move initialisation to solver solution (skipping BCs). + no=0 + do depvar=1,mesh_dof !loop over mesh dofs + if(.NOT.FIX(depvar))then + no=no+1 + solver_solution(no)=prq_solution(depvar,1) + endif + enddo !mesh_dof + else!flow BCs to be implemented + endif + else!Need to update just the resistance values in the solution matrix + do ne=1,num_elems !update for all ne + if(update_resistance_entries(ne).gt.0)then + nz=update_resistance_entries(ne) + SparseVal(nz)=-elem_field(ne_resist,ne) !Just updating resistance + endif + enddo + if(bc_type.eq.'flow')then !update RHS to account for element resistance + do ne=1,num_elems + depvar = depvar_at_elem(1,1,ne) + if(FIX(depvar))then + RHS(update_flow_nzz_row) = prq_solution(depvar,1)*elem_field(ne_resist,ne) + endif + enddo + !SparseVal(nz)=-elem_field(ne_resist,ne) !Just updating resistance + endif + endif!first or subsequent iteration + !! ----CALL SOLVER---- + call pmgmres_ilu_cr(MatrixSize, NonZeros, SparseRow, SparseCol, SparseVal, & + solver_solution, RHS, 500, 500,1.d-5,1.d-4,SOLVER_FLAG) + if(SOLVER_FLAG == 0)then + print *, 'Warning: pmgmres has reached max iterations. Solution may not be valid if this warning persists' + elseif(SOLVER_FLAG ==2)then + print *, 'ERROR: pmgmres has failed to converge' + deallocate (mesh_from_depvar, STAT = AllocateStatus) + deallocate (depvar_at_elem, STAT = AllocateStatus) + deallocate (depvar_at_node, STAT = AllocateStatus) + deallocate (prq_solution, STAT = AllocateStatus) + deallocate (FIX, STAT = AllocateStatus) + deallocate (solver_solution, STAT = AllocateStatus) + deallocate (SparseCol, STAT = AllocateStatus) + deallocate (SparseVal, STAT = AllocateStatus) + deallocate (SparseRow, STAT = AllocateStatus) + deallocate (RHS, STAT = AllocateStatus) + deallocate (update_resistance_entries, STAT=AllocateStatus) + exit + endif +!!--TRANSFER SOLVER SOLUTIONS TO FULL SOLUTIONS + ERR=0.0_dp + no=0 + do depvar=1,mesh_dof + if(.NOT.FIX(depvar)) THEN + no=no+1 + prq_solution(depvar,2)=prq_solution(depvar,1) !temp storage of previous solution + prq_solution(depvar,1)=solver_solution(no) !new pressure & flow solutions + if(DABS(prq_solution(depvar,1)).GT.0.d-6)THEN + ERR=ERR+(prq_solution(depvar,2)-prq_solution(depvar,1))**2.d0/prq_solution(depvar,1)**2 + endif + endif + enddo !no2 +!rigid vessels no need to update - tag as converged and exit + if(vessel_type.eq.'rigid')then + ERR=0.0_dp + CONVERGED=.TRUE. + else +!Update vessel radii based on predicted pressures and then update resistance through tree + call calc_press_area(grav_vect,KOUNT,depvar_at_node,prq_solution,& + mesh_dof,vessel_type,elasticity_parameters,mechanics_parameters) + call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) + +!Put the ladder stuff here --> See solve11.f + if(mesh_type.eq.'full_plus_ladder')then + do ne=1,num_elems + if(elem_field(ne_group,ne).eq.1.0_dp)then!(elem_field(ne_group,ne)-1.0_dp).lt.TOLERANCE)then + ne0=elem_cnct(-1,1,ne)!upstream element number + ne1=elem_cnct(1,1,ne) + P1=prq_solution(depvar_at_node(elem_nodes(2,ne0),0,1),1) !pressure at start node of capillary element + P2=prq_solution(depvar_at_node(elem_nodes(1,ne1),0,1),1)!pressure at end node of capillary element + Q01=prq_solution(depvar_at_elem(1,1,ne0),1) !flow in element upstream of capillary element !mm^3/s + Rin=elem_field(ne_radius_out0,ne0)!radius of upstream element + Rout=elem_field(ne_radius_out0,ne1) !radius of downstream element + x_cap=node_xyz(1,elem_nodes(1,ne)) + y_cap=node_xyz(2,elem_nodes(1,ne)) + z_cap=node_xyz(3,elem_nodes(1,ne)) + call calculate_ppl(elem_nodes(1,ne),grav_vect,mechanics_parameters,Ppl) + Lin=elem_field(ne_length,ne0) + Lout=elem_field(ne_length,ne1) + call cap_flow_ladder(ne,LPM_R,Lin,Lout,P1,P2,& + Ppl,Q01,Rin,Rout,x_cap,y_cap,z_cap,& + .FALSE.) + elem_field(ne_resist,ne)=LPM_R + endif + enddo + endif + ERR=ERR/MatrixSize !sum of error divided by no of unknown depvar + if(ERR.LE.1.d-6.AND.(KOUNT.NE.1))then + CONVERGED=.TRUE. + write(*,'('' Convergence achieved after'',i4,'' iterations, error ='',e10.3)') KOUNT,ERR + else !if error not converged + if(ERR.GE.MIN_ERR) then + N_MIN_ERR=N_MIN_ERR+1 + else + MIN_ERR=ERR + endif + write(*,'('' Not converged, error ='',e10.3)') ERR + endif !ERR not converged + endif!vessel type + enddo !notconverged + +!need to write solution to element/nodal fields for export + call map_solution_to_mesh(prq_solution,depvar_at_elem,depvar_at_node,mesh_dof) + !NEED TO UPDATE TERMINAL SOLUTION HERE. LOOP THO' UNITS AND TAKE FLOW AND PRESSURE AT TERMINALS + call map_flow_to_terminals + !EXPORT LADDER SOLUTION + if(mesh_type.eq.'full_plus_ladder')then + open(10, file='micro_flow_ladder.out', status='replace') + open(20, file='micro_flow_unit.out', status='replace') + do ne=1,num_elems + if(elem_field(ne_group,ne).eq.1.0_dp)then!(elem_field(ne_group,ne)-1.0_dp).lt.TOLERANCE)then + ne0=elem_cnct(-1,1,ne)!upstream element number + ne1=elem_cnct(1,1,ne) + P1=prq_solution(depvar_at_node(elem_nodes(2,ne0),0,1),1) !pressure at start node of capillary element + P2=prq_solution(depvar_at_node(elem_nodes(1,ne1),0,1),1)!pressure at end node of capillary element + Q01=prq_solution(depvar_at_elem(1,1,ne0),1) !flow in element upstream of capillary element !mm^3/s + Rin=elem_field(ne_radius_out0,ne0)!radius of upstream element + Rout=elem_field(ne_radius_out0,ne1) !radius of downstream element + x_cap=node_xyz(1,elem_nodes(1,ne)) + y_cap=node_xyz(2,elem_nodes(1,ne)) + z_cap=node_xyz(3,elem_nodes(1,ne)) + call calculate_ppl(elem_nodes(1,ne),grav_vect,mechanics_parameters,Ppl) + Lin=elem_field(ne_length,ne0) + Lout=elem_field(ne_length,ne1) + call cap_flow_ladder(ne,LPM_R,Lin,Lout,P1,P2,& + Ppl,Q01,Rin,Rout,x_cap,y_cap,z_cap,& + .TRUE.) + endif + enddo + close(10) + close(20) + endif + + write(*,'('' Cardiac output ='',f8.3,'' L/min for PAP ='',f8.3,'' mmHg and LAP ='',f8.3,'' mmHg'')') & + elem_field(ne_Qdot,1)/1.0e6_dp*60.0_dp, inletbc / 133.322_dp, outletbc / 133.322_dp + + call enter_exit(sub_name,2) + + end subroutine update_prq ! !################################################################## ! diff --git a/src/lib/species_transport.f90 b/src/lib/species_transport.f90 index b027045e..54fec480 100644 --- a/src/lib/species_transport.f90 +++ b/src/lib/species_transport.f90 @@ -57,8 +57,8 @@ subroutine initialise_transport() !Note that as V, Q are prerequisites something needs to be added here that checks !these have been read in and if not sets up linear gradient based on some default parameters !note a linear q gradient should be set up to scale for shunt fraction automatically - call initial_gasexchange(149.0_dp) - call solve_transport + !call initial_gasexchange(149.0_dp) + !call solve_transport end select call enter_exit(sub_name,2) @@ -94,9 +94,9 @@ subroutine solve_transport() p_ven_co2=45.0_dp p_art_o2=100.0_dp p_ven_o2=40.0_dp - call steadystate_gasexchange(c_art_o2,c_ven_o2,& - p_art_co2,p_art_o2,149.0_dp,p_ven_co2,p_ven_o2,0.03_dp,& - 0.8_dp*(260.0_dp*1.0e+3_dp/60.0_dp),260.0_dp*1.0e+3_dp/60.0_dp ) +! call steadystate_gasexchange(c_art_o2,c_ven_o2,& +! p_art_co2,p_art_o2,149.0_dp,p_ven_co2,p_ven_o2,0.03_dp,& +! 0.8_dp*(260.0_dp*1.0e+3_dp/60.0_dp),260.0_dp*1.0e+3_dp/60.0_dp ) end select call enter_exit(sub_name,2) diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index 4be8111b..396f5314 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -633,7 +633,6 @@ end subroutine update_elem_field subroutine update_resistance - type(fluid_properties) :: fluid_param ! Local variables integer :: i,ne,ne2,np1,np2,nunit real(dp) :: ett_resistance,gamma,le,rad,resistance,reynolds,sum,zeta @@ -662,15 +661,15 @@ subroutine update_resistance rad = elem_field(ne_radius,ne) ! element Poiseuille (laminar) resistance in units of Pa.s.mm-3 - resistance = 8.0_dp*fluid_param%air_viscosity*elem_field(ne_length,ne)/ & + resistance = 8.0_dp*fluid_properties%air_viscosity*elem_field(ne_length,ne)/ & (PI*elem_field(ne_radius,ne)**4) !laminar resistance ! element turbulent resistance (flow in bifurcating tubes) gamma = 0.357_dp !inspiration if(elem_field(ne_Vdot,ne).lt.0.0_dp) gamma = 0.46_dp !expiration - reynolds = abs(elem_field(ne_Vdot,ne)*2.0_dp*fluid_param%air_density/ & - (pi*elem_field(ne_radius,ne)*fluid_param%air_viscosity)) + reynolds = abs(elem_field(ne_Vdot,ne)*2.0_dp*fluid_properties%air_density/ & + (pi*elem_field(ne_radius,ne)*fluid_properties%air_viscosity)) zeta = MAX(1.0_dp,dsqrt(2.0_dp*elem_field(ne_radius,ne)* & reynolds/elem_field(ne_length,ne))*gamma) elem_field(ne_resist,ne) = resistance * zeta diff --git a/src/lib/wave_transmission.f90 b/src/lib/wave_transmission.f90 index d907f84a..50f6f182 100644 --- a/src/lib/wave_transmission.f90 +++ b/src/lib/wave_transmission.f90 @@ -52,7 +52,6 @@ subroutine evaluate_wave_transmission(grav_dirn,grav_factor,& integer, intent(in) :: cap_model type(all_admit_param) :: admit_param - type(fluid_properties) :: fluid type(elasticity_param) :: elast_param character(len=60) :: mesh_type @@ -94,11 +93,11 @@ subroutine evaluate_wave_transmission(grav_dirn,grav_factor,& endif !viscosity and density of fluid if(model_definition(2).eq.1.0_dp)then !BLOOD - viscosity=fluid%blood_viscosity - density=fluid%blood_density + viscosity=fluid_properties%blood_viscosity + density=fluid_properties%blood_density elseif(model_definition(2).eq.2.0_dp)then !AIR - viscosity=fluid%air_viscosity - density=fluid%air_density + viscosity=fluid_properties%air_viscosity + density=fluid_properties%air_density else viscosity=model_definition(3) density=model_definition(4) From 69dcc5abf1ad00e899721ce2140b7c295f02b92a Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 3 Sep 2021 09:32:00 +1200 Subject: [PATCH 15/25] export option for 2d cubic hermite mesh; change in method for setting up lines on a 2d mesh --- src/bindings/c/exports.c | 66 ++++++++--- src/bindings/c/exports.f90 | 28 +++++ src/bindings/c/exports.h | 1 + src/lib/exports.f90 | 152 +++++++++++++++++++++++++ src/lib/geometry.f90 | 224 ++++++++----------------------------- 5 files changed, 276 insertions(+), 195 deletions(-) diff --git a/src/bindings/c/exports.c b/src/bindings/c/exports.c index 77c46bc5..0862fbbd 100644 --- a/src/bindings/c/exports.c +++ b/src/bindings/c/exports.c @@ -4,29 +4,54 @@ #include +void export_cubic_lagrange_2d_c(const char *EXFILE, int *exfile_len, + const char *group_name, int *group_name_len); void export_1d_elem_field_c(int *ne_field, const char *EXELEMFILE, int *EXELEMFILE_LEN, - const char *group_name, int *group_name_len, const char *field_name, int *field_name_len ); -void export_1d_elem_geometry_c(const char *EXELEMFILE, int *EXELEMFILE_LEN, const char *name, int *name_len); -void export_elem_geometry_2d_c(const char *EXELEMFILE, int *EXELEMFILE_LEN, const char *name, int *name_len, int *offset_elem, int *offset_node); + const char *group_name, int *group_name_len, + const char *field_name, int *field_name_len ); +void export_1d_elem_geometry_c(const char *EXELEMFILE, int *EXELEMFILE_LEN, + const char *name, int *name_len); +void export_elem_geometry_2d_c(const char *EXELEMFILE, int *EXELEMFILE_LEN, + const char *name, int *name_len, int *offset_elem, int *offset_node); void export_node_field_c(int *nj_field, const char *EXNODEFIELD, int *EXNODEFIELD_LEN, const char *name, int *name_len, const char *field_name, int *field_name_len); -void export_elem_geometry_2d_c(const char *EXELEMFILE, int *EXELEMFILE_LEN, const char *name, int *name_len, int *offset_elem, int *offset_node); -void export_terminal_solution_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, const char *name, int *name_len); -void export_terminal_perfusion_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, const char *name, int *name_len); -void export_node_geometry_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, const char *name, int *name_len); -void export_node_geometry_2d_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, const char *name, int *name_len, int *offset); -void export_data_geometry_c(const char *EXDATAFILE, int *EXDATAFILE_LEN, const char *name, int *name_len, int *offset); +void export_elem_geometry_2d_c(const char *EXELEMFILE, int *EXELEMFILE_LEN, + const char *name, int *name_len, int *offset_elem, int *offset_node); +void export_terminal_solution_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, + const char *name, int *name_len); +void export_terminal_perfusion_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, + const char *name, int *name_len); +void export_node_geometry_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, + const char *name, int *name_len); +void export_node_geometry_2d_c(const char *EXNODEFILE, int *EXNODEFILE_LEN, + const char *name, int *name_len, int *offset); +void export_data_geometry_c(const char *EXDATAFILE, int *EXDATAFILE_LEN, + const char *name, int *name_len, int *offset); void export_elem_field_c(const char *EXELEMFIELD, int *EXELEMFIELD_LEN, - const char *name, int *name_len, const char *field_name, int *field_name_len); -void export_terminal_ssgexch_c(const char *EXNODEFILE, int *filename_len, const char *name, int *name_len); + const char *name, int *name_len, const char *field_name, + int *field_name_len); +void export_terminal_ssgexch_c(const char *EXNODEFILE, int *filename_len, + const char *name, int *name_len); + + + +void export_cubic_lagrange_2d(const char *EXFILE, const char *group_name) +{ + int filename_len = strlen(EXFILE); + int group_name_len = strlen(group_name); + + export_cubic_lagrange_2d_c(EXFILE, &filename_len, group_name, &group_name_len); +} -void export_1d_elem_field(int ne_field, const char *EXELEMFILE, const char *group_name, const char *field_name ) +void export_1d_elem_field(int ne_field, const char *EXELEMFILE, + const char *group_name, const char *field_name ) { int filename_len = strlen(EXELEMFILE); int group_name_len = strlen(group_name); int field_name_len = strlen(field_name); - export_1d_elem_field_c(&ne_field, EXELEMFILE, &filename_len, group_name, &group_name_len, field_name, &field_name_len); + export_1d_elem_field_c(&ne_field, EXELEMFILE, &filename_len, group_name, + &group_name_len, field_name, &field_name_len); } void export_1d_elem_geometry(const char *EXELEMFILE, const char *name) @@ -37,21 +62,25 @@ void export_1d_elem_geometry(const char *EXELEMFILE, const char *name) export_1d_elem_geometry_c(EXELEMFILE, &filename_len, name, &name_len); } -void export_elem_geometry_2d(const char *EXELEMFILE, const char *name, int offset_elem, int offset_node) +void export_elem_geometry_2d(const char *EXELEMFILE, const char *name, + int offset_elem, int offset_node) { int filename_len = strlen(EXELEMFILE); int name_len = strlen(name); - export_elem_geometry_2d_c(EXELEMFILE, &filename_len, name, &name_len, &offset_elem, &offset_node); + export_elem_geometry_2d_c(EXELEMFILE, &filename_len, name, &name_len, + &offset_elem, &offset_node); } -void export_node_field(int nj_field, const char *EXNODEFIELD, const char *name, const char *field_name) +void export_node_field(int nj_field, const char *EXNODEFIELD, + const char *name, const char *field_name) { int filename_len = strlen(EXNODEFIELD); int name_len = strlen(name); int field_name_len = strlen(field_name); - export_node_field_c(&nj_field, EXNODEFIELD, &filename_len, name, &name_len, field_name, &field_name_len); + export_node_field_c(&nj_field, EXNODEFIELD, &filename_len, name, + &name_len, field_name, &field_name_len); } void export_terminal_solution(const char *EXNODEFILE, const char *name) @@ -108,6 +137,7 @@ void export_elem_field(const char *EXELEMFIELD, const char *name, const char *fi int name_len = strlen(name); int field_name_len = strlen(field_name); - export_elem_field_c(EXELEMFIELD, &filename_len, name, &name_len, field_name, &field_name_len); + export_elem_field_c(EXELEMFIELD, &filename_len, name, &name_len, + field_name, &field_name_len); } diff --git a/src/bindings/c/exports.f90 b/src/bindings/c/exports.f90 index aa692f3e..ee4c2426 100644 --- a/src/bindings/c/exports.f90 +++ b/src/bindings/c/exports.f90 @@ -4,6 +4,34 @@ module exports_c private contains + + +!!!################################################################ + + subroutine export_cubic_lagrange_2d_c(EXFILE, filename_len, group_name, group_name_len) & + bind(C, name="export_cubic_lagrange_2d_c") + + use iso_c_binding, only: c_ptr + use utils_c, only: strncpy + use exports, only: export_cubic_lagrange_2d + use other_consts, only: MAX_STRING_LEN, MAX_FILENAME_LEN + implicit none + integer,intent(in) :: filename_len, group_name_len + type(c_ptr), value, intent(in) :: EXFILE, group_name + character(len=MAX_FILENAME_LEN) :: filename_f + character(len=MAX_STRING_LEN) :: group_name_f + + call strncpy(filename_f, EXFILE, filename_len) + call strncpy(group_name_f, group_name, group_name_len) + +#if defined _WIN32 && defined __INTEL_COMPILER + call so_export_cubic_lagrange_2d(filename_f, group_name_f) +#else + call export_cubic_lagrange_2d(filename_f, group_name_f) +#endif + + end subroutine export_cubic_lagrange_2d_c + !!!################################################################ subroutine export_1d_elem_field_c(ne_field, EXELEMFILE, filename_len, group_name, group_name_len, field_name, field_name_len) & diff --git a/src/bindings/c/exports.h b/src/bindings/c/exports.h index 7f8bbdff..5b93271e 100644 --- a/src/bindings/c/exports.h +++ b/src/bindings/c/exports.h @@ -4,6 +4,7 @@ #include "symbol_export.h" +SHO_PUBLIC void export_cubic_lagrange_2d(const char *EXFILE, const char *group_name); SHO_PUBLIC void export_1d_elem_field(int ne_field, const char *EXELEMFILE, const char *group_name, const char *field_name ); SHO_PUBLIC void export_1d_elem_geometry(const char *EXELEMFILE, const char *name); SHO_PUBLIC void export_elem_geometry_2d(const char *EXELEMFILE, const char *name, int offset_elem, int offset_node); diff --git a/src/lib/exports.f90 b/src/lib/exports.f90 index 576d08f6..ec88aee5 100644 --- a/src/lib/exports.f90 +++ b/src/lib/exports.f90 @@ -21,6 +21,7 @@ module exports private public & export_1d_elem_geometry, & + export_cubic_lagrange_2d, & export_elem_geometry_2d, & export_node_geometry, & export_node_geometry_2d,& @@ -39,7 +40,158 @@ module exports ! !############################################################################## ! + subroutine export_cubic_lagrange_2d(EXFILE,groupname) + !*export_cubic_lagrange_2d:* write our node and element structure for + ! cubic lagrange mesh, converted from existing cubic Hermite mesh + !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_EXPORT_CUBIC_LAGRANGE_2D" :: EXPORT_CUBIC_LAGRANGE_2D + + use geometry,only: coord_at_xi + character(len=*) :: EXFILE + character(len=*) :: groupname + + integer,allocatable :: nodes_at_centre(:),nodes_on_lines(:), & + node_xyz_2d_temp(:,:,:,:) + integer,allocatable :: nodes_cl(:),nodes_cl_elems(:,:) + integer :: index_nodes(4),j,ne,new_node,ni,nj,nl,nline, & + nlist(4),nn,np,np1,np2,num_cl_nodes + real(dp),allocatable :: xyz(:,:) + real(dp) :: xi_lines(2,4),xi(2) + character(len=1) :: direction(3) + character(len=60) :: sub_name = 'export_cubic_lagrange_2d' + character(len=300) :: writefile + + call enter_exit(sub_name,1) + + ! overallocating the minimum required memory, just to make indexing of nodes easy + allocate(nodes_on_lines(num_nodes_2d+num_lines_2d)) + nodes_on_lines = 0 + allocate(nodes_at_centre(num_nodes_2d+num_elems_2d)) + nodes_at_centre = 0 + allocate(xyz(3,num_nodes_2d+num_lines_2d+num_elems_2d)) + xyz = 0.0_dp + xyz(:,1:num_nodes_2d) = node_xyz_2d(1,1,:,1:num_nodes_2d) + allocate(nodes_cl_elems(9,num_elems_2d)) + nodes_cl_elems = 0 + allocate(nodes_cl(num_nodes_2d+num_lines_2d+num_elems_2d)) + nodes_cl(1:num_nodes_2d) = nodes_2d(1:num_nodes_2d) + + xi_lines = reshape([0.5_dp,0.0_dp,0.5_dp,1.0_dp,0.0_dp,0.5_dp,1.0_dp,0.5_dp],shape(xi_lines)) + index_nodes = [2,8,4,6] + + new_node = num_nodes_2d !int(maxval(nodes_2d)) + num_cl_nodes = num_nodes_2d + + do ne = 1,num_elems_2d + do nl = 1,4 ! 2,8,4,6 + nline = elem_lines_2d(nl,ne) + np1 = nodes_in_line(2,1,nline) + np2 = nodes_in_line(3,1,nline) + if(nl.eq.1)then + nodes_cl_elems(1,ne) = np1 !y + nodes_cl_elems(3,ne) = np2 !y + elseif(nl.eq.2)then + nodes_cl_elems(7,ne) = np1 !y + nodes_cl_elems(9,ne) = np2 !y + endif + if(np1.ne.np2)then ! only for non-repeated nodes + if(nodes_on_lines(nline).eq.0)then ! make a node on the line + xi = xi_lines(:,nl) + new_node = new_node + 1 + num_cl_nodes = num_cl_nodes + 1 + nodes_cl(num_cl_nodes) = new_node + nodes_on_lines(nline) = num_cl_nodes + xyz(:,num_cl_nodes) = coord_at_xi(ne,xi,'hermite') + endif + nodes_cl_elems(index_nodes(nl),ne) = nodes_on_lines(nline) + else + nodes_cl_elems(index_nodes(nl),ne) = np1 + endif + enddo !nl + xi = 0.5_dp ! for node at the centre + new_node = new_node + 1 + num_cl_nodes = num_cl_nodes + 1 + nodes_cl(num_cl_nodes) = new_node + xyz(:,num_cl_nodes) = coord_at_xi(ne,xi,'hermite') + nodes_cl_elems(5,ne) = new_node !y + enddo !ne + + writefile = trim(EXFILE)//'.lsnode' + open(10, file = writefile, status = 'replace') + writefile = trim(EXFILE)//'.exnode' + open(20, file = writefile, status = 'replace') + write(10,'(i6)') num_cl_nodes + write(20,'( '' Group name: '',A)') trim(groupname) + write(20,'( '' #Fields=1'' )') + write(20,'('' 1) coordinates, coordinate, rectangular cartesian, #Components=3'')') + write(20,'(2X,''x. Value index=1, #Derivatives=0'')') + write(20,'(2X,''y. Value index=1, #Derivatives=0'')') + write(20,'(2X,''z. Value index=1, #Derivatives=0'')') + do np = 1,num_cl_nodes + write(10,'(i6,3(f14.5))') np,xyz(1:3,np) + write(20,'(1X,''Node: '',i8)') np + write(20,'(2X,3(1X,F12.6))') xyz(1:3,np) + enddo + close(10) + close(20) + + writefile = trim(EXFILE)//'.lselem' + open(10, file = writefile, status = 'replace') + write(10,'(i6)') num_elems_2d + + writefile = trim(EXFILE)//'.exelem' + open(20, file = writefile, status = 'replace') + direction = ['x', 'y', 'z'] + write(20,'('' Group name: '',A)') trim(groupname) + write(20,'('' Shape. Dimension=1'' )') + do nl = 1,num_lines_2d + write(20,'('' Element: 0 0 '',i6)') lines_2d(nl) + enddo + write(20,'('' Shape. Dimension=2'')') + write(20,'('' #Scale factor sets= 1'')') + write(20,'('' q.Lagrange*q.Lagrange, #Scale factors= 9'')') + write(20,'('' #Nodes= 9'')') + write(20,'('' #Fields=1'')') + write(20,'('' 1) coordinates, coordinate, rectangular '' & + ''cartesian, #Components=3'')') + do nj = 1,3 + write(20,'(3x, a,''. q.Lagrange*q.Lagrange, no modify,'' & + '' standard node based.'')') direction(nj) + write(20,'(5x,''#Nodes= 9'')') + do ni = 1,9 + write(20,'(6x, i1,''.#Values=1'')') ni + write(20,'(7x,''Value indices: 1'')') + write(20,'(7x,''Scale factor indices:'',i4)') ni + enddo + enddo + + do ne = 1,num_elems_2d + write(10,'(10(i6))') ne,nodes_cl_elems(1:9,ne) + write(20,'('' Element:'',i6,'' 0 0'')')ne + write(20,'('' Faces:'')') + write(20,'('' 0 0'',i6)') elem_lines_2d(1,ne) + write(20,'('' 0 0'',i6)') elem_lines_2d(2,ne) + write(20,'('' 0 0'',i6)') elem_lines_2d(3,ne) + write(20,'('' 0 0'',i6)') elem_lines_2d(4,ne) + write(20,'('' Nodes:'')') + write(20,'(9(i10))') nodes_cl_elems(1:9,ne) + write(20,'('' Scale factors:'')') + write(20,'('' 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0'')') + enddo + close(10) + close(20) + + deallocate(nodes_on_lines) + deallocate(nodes_at_centre) + deallocate(nodes_cl_elems) + deallocate(xyz) + + call enter_exit(sub_name,2) + + end subroutine export_cubic_lagrange_2d +! +!############################################################################## +! subroutine export_triangle_elements(num_triangles,triangle,EXELEMFILE,groupname) !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_EXPORT_TRIANGLE_ELEMENTS" :: EXPORT_TRIANGLE_ELEMENTS diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 3b7e8240..283892ce 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -28,6 +28,7 @@ module geometry public add_mesh public add_matching_mesh public append_units + public coord_at_xi public define_1d_elements public define_elem_geometry_2d public define_mesh_geometry_test @@ -756,7 +757,7 @@ subroutine define_elem_geometry_2d(ELEMFILE,sf_option) call element_connectivity_2d call line_segments_for_2d_mesh(sf_option) - + call enter_exit(sub_name,2) end subroutine define_elem_geometry_2d @@ -1458,11 +1459,8 @@ subroutine make_data_grid(surface_elems, offset, spacing, filename, groupname) ! fill a bounding surface !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_MAKE_DATA_GRID" :: MAKE_DATA_GRID - use exports,only: export_triangle_elements,export_triangle_nodes - integer,intent(in) :: surface_elems(:) real(dp),intent(in) :: offset, spacing - logical :: to_export = .true. character(len=*),intent(in) :: filename character(len=*),intent(in) :: groupname ! Local Variables @@ -1487,13 +1485,6 @@ subroutine make_data_grid(surface_elems, offset, spacing, filename, groupname) call triangles_from_surface(num_triangles,num_vertices,elem_list, & triangle,vertex_xyz) - if(to_export)then -!!! export vertices as nodes - call export_triangle_nodes(num_vertices,vertex_xyz,filename,groupname) -!!! export the triangles as surface elements - call export_triangle_elements(num_triangles,triangle,filename,groupname) - endif - scale_mesh = 1.0_dp-(offset/100.0_dp) cofm1 = sum(vertex_xyz,dim=2)/num_vertices forall (i = 1:num_vertices) vertex_xyz(1:3,i) = & @@ -2937,48 +2928,29 @@ subroutine line_segments_for_2d_mesh(sf_option) character(len=4),intent(in) :: sf_option ! Local variables - integer :: ne,ne_adjacent,ni1,nj,nl,nl_adj,npn(2) + integer :: index_nodes(2,4),j,line_nodes(2),ne,ne_adjacent,ni1,nj, & + nl,nline,nl_adj,nl_found,npn(2),np1,np2,nxi(4) logical :: MAKE - logical :: based_on_elems = .true. + logical :: based_on_elems = .true., found_nl character(len=60) :: sub_name ! -------------------------------------------------------------------------- sub_name = 'line_segments_for_2d_mesh' call enter_exit(sub_name,1) + + nxi = [1,1,2,2] + index_nodes = reshape([1,2,3,4,1,3,2,4],shape(index_nodes)) - ! allocate elem_lines_2d, scale_factors_2d,lines_2d,line_versn_2d,lines_in_elem,nodes_in_line,arclength if(allocated(elem_lines_2d)) deallocate(elem_lines_2d) if(allocated(scale_factors_2d)) deallocate(scale_factors_2d) allocate(elem_lines_2d(4,num_elems_2d)) allocate(scale_factors_2d(16,num_elems_2d)) - elem_lines_2d=0 - num_lines_2d = 0 + elem_lines_2d = 0 + num_lines_2d = 4 * num_elems_2d if(based_on_elems)then -!!! estimate number of lines, for allocating memory to arrays -!!! before setting up arrays, count the number of lines required - do ne=1,num_elems_2d - MAKE=.FALSE. - if(elem_cnct_2d(-1,0,ne) == 0) MAKE=.TRUE. !exterior, make line - ne_adjacent=elem_cnct_2d(-1,1,ne) - if(ne_adjacent > 0)then - if(elem_lines_2d(4,ne_adjacent) == 0) MAKE=.TRUE. - endif - if(MAKE) num_lines_2d = num_lines_2d+1 - MAKE=.FALSE. - if(elem_cnct_2d(-2,0,ne) == 0) MAKE=.TRUE. !exterior, make line - ne_adjacent=elem_cnct_2d(-2,1,ne) - if(ne_adjacent > 0)then - if(elem_lines_2d(2,ne_adjacent) == 0) MAKE=.TRUE. - endif - if(MAKE) num_lines_2d=num_lines_2d+1 - num_lines_2d = num_lines_2d+2 - elem_lines_2d(2,ne) = 1 ! at this stage just to tag it for conditional above - elem_lines_2d(4,ne) = 1 ! at this stage just to tag it for conditional above - enddo !ne - elem_lines_2d = 0 if(allocated(lines_2d)) deallocate(lines_2d) @@ -2990,148 +2962,46 @@ subroutine line_segments_for_2d_mesh(sf_option) allocate(line_versn_2d(2,3,num_lines_2d)) allocate(lines_in_elem(0:4,num_lines_2d)) allocate(nodes_in_line(3,0:3,num_lines_2d)) - !allocate(arclength(num_lines_2d)) - lines_in_elem=0 - lines_2d=0 - nodes_in_line=0 - line_versn_2d=0 + lines_in_elem = 0 + lines_2d = 0 + nodes_in_line = 0 + line_versn_2d = 0 num_lines_2d = 0 ! reset to zero for loop below - -!!! Now run through the same as above, and set up the arrays - do ne=1,num_elems_2d - !check whether to make a line - MAKE=.FALSE. - if(elem_cnct_2d(-1,0,ne) == 0) MAKE=.TRUE. !exterior, make line - ne_adjacent=elem_cnct_2d(-1,1,ne) - if(ne_adjacent.gt.0)then - if(elem_lines_2d(4,ne_adjacent) == 0) MAKE=.TRUE. - endif - if(MAKE)then - num_lines_2d = num_lines_2d+1 - lines_2d(num_lines_2d) = num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d) = lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d) = ne !line num_lines_2d is in element ne - elem_lines_2d(3,ne) = num_lines_2d !num_lines_2d is global line # corresponding to local line 3 of ne - npn(1) = 1 - npn(2) = 3 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(1,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(3,ne) !records 2nd node in line - nodes_in_line(1,0,num_lines_2d)=2 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - else !get adjacent element line number - !WARNING:: this only works if all Xi directions are consistent!!!! - ne_adjacent=elem_cnct_2d(-1,1,ne) - elem_lines_2d(3,ne)=elem_lines_2d(4,ne_adjacent) - endif - - !check whether to make a line - MAKE=.FALSE. - if(elem_cnct_2d(-2,0,ne) == 0) MAKE=.TRUE. !exterior, make line - ne_adjacent=elem_cnct_2d(-2,1,ne) - if(ne_adjacent.gt.0)then - if(elem_lines_2d(2,ne_adjacent) == 0) MAKE=.TRUE. - endif - - if(MAKE)then - num_lines_2d=num_lines_2d+1 - lines_2d(num_lines_2d)=num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d)=lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d)=ne !line num_lines_2d is in element ne - elem_lines_2d(1,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 1 of ne - npn(1)=1 - npn(2)=2 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(1,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(2,ne) !records 2nd node in line - nodes_in_line(1,0,num_lines_2d)=1 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - else !get adjacent element line number - !WARNING:: this only works if all Xi directions are consistent!!!! - ne_adjacent = elem_cnct_2d(-2,1,ne) - do nl_adj = 1,4 - nl = elem_lines_2d(nl_adj,ne_adjacent) - if(nl /= 0)then - if(nodes_in_line(2,1,nl) == elem_nodes_2d(1,ne) .and. & - nodes_in_line(3,1,nl) == elem_nodes_2d(2,ne))then - elem_lines_2d(1,ne) = nl - elseif(nodes_in_line(2,1,nl) == elem_nodes_2d(2,ne) .and. & - nodes_in_line(3,1,nl) == elem_nodes_2d(1,ne))then - elem_lines_2d(1,ne) = nl + + do ne = 1,num_elems_2d + do nline = 1,4 + np1 = elem_nodes_2d(index_nodes(1,nline),ne) + np2 = elem_nodes_2d(index_nodes(2,nline),ne) + found_nl = .false. + if(np1.ne.np2)then + do nl = 1,num_lines_2d + forall(j=1:2) line_nodes(j) = nodes_in_line(j+1,1,nl) + if(inlist(np1,line_nodes) .and. inlist(np2,line_nodes))then + found_nl = .true. + nl_found = nl endif - endif - enddo - ! elem_lines_2d(1,ne)=elem_lines_2d(2,ne_adjacent) - endif - - !*! new: - MAKE=.TRUE. - ne_adjacent=elem_cnct_2d(1,1,ne) - if(ne_adjacent.gt.0)then - if(elem_lines_2d(3,ne_adjacent) /= 0) MAKE=.FALSE. - endif - - if(MAKE)then - num_lines_2d=num_lines_2d+1 - lines_2d(num_lines_2d)=num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d)=lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d)=ne !line num_lines_2d is in element ne - elem_lines_2d(4,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 4 of ne - npn(1)=2 - npn(2)=4 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(2,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(4,ne) !records 2nd node in line - nodes_in_line(1,0,num_lines_2d)=2 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - else !get adjacent element line number - !WARNING:: this only works if all Xi directions are consistent!!!! - ne_adjacent=elem_cnct_2d(1,1,ne) - elem_lines_2d(4,ne)=elem_lines_2d(3,ne_adjacent) - endif - - MAKE=.TRUE. - ne_adjacent=elem_cnct_2d(2,1,ne) - if(ne_adjacent.gt.0)then - if(elem_lines_2d(1,ne_adjacent) /= 0) MAKE=.FALSE. - endif - - if(MAKE)then - num_lines_2d = num_lines_2d+1 - lines_2d(num_lines_2d) = num_lines_2d !record a new line number - lines_in_elem(0,num_lines_2d) = lines_in_elem(0,num_lines_2d)+1 - lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d) = ne !line num_lines_2d is in element ne - elem_lines_2d(2,ne)=num_lines_2d !num_lines_2d is global line # corresponding to local line 2 of ne - npn(1) = 3 - npn(2) = 4 - nodes_in_line(2,1,num_lines_2d)=elem_nodes_2d(3,ne) !records 1st node in line - nodes_in_line(3,1,num_lines_2d)=elem_nodes_2d(4,ne) !records 2nd node in line - nodes_in_line(1,0,num_lines_2d)=1 !Xi-direction of line segment num_lines_2d - do nj=1,3 - nodes_in_line(1,nj,num_lines_2d)=4 !type of basis function (1 for linear,4 for cubicHermite) - do ni1=1,2 - line_versn_2d(ni1,nj,num_lines_2d)=elem_versn_2d(npn(ni1),ne) - enddo !n - enddo !nj - else !get adjacent element line number - !WARNING:: this only works if all Xi directions are consistent!!!! - ne_adjacent=elem_cnct_2d(2,1,ne) - elem_lines_2d(2,ne)=elem_lines_2d(1,ne_adjacent) - endif - enddo !ne + enddo !nl + endif + if(found_nl)then + elem_lines_2d(nline,ne) = nl_found + else ! make a new line + num_lines_2d = num_lines_2d + 1 + lines_2d(num_lines_2d) = num_lines_2d !record a new line number + lines_in_elem(0,num_lines_2d) = lines_in_elem(0,num_lines_2d) + 1 + lines_in_elem(lines_in_elem(0,num_lines_2d),num_lines_2d) = ne !line num_lines_2d is in element ne + elem_lines_2d(nline,ne) = num_lines_2d + nodes_in_line(2,1,num_lines_2d) = np1 + nodes_in_line(3,1,num_lines_2d) = np2 + nodes_in_line(1,0,num_lines_2d) = nxi(nline) + do nj = 1,3 + nodes_in_line(1,nj,num_lines_2d) = 4 !type of basis function (1 for linear,4 for cubicHermite) + line_versn_2d(1,nj,num_lines_2d) = elem_versn_2d(np1,ne) + line_versn_2d(2,nj,num_lines_2d) = elem_versn_2d(np2,ne) + enddo !nj + endif + enddo !nline + enddo ! ne endif call calc_scale_factors_2d(sf_option) From 247cbbd74649eaa24f12cebd98300b432e406b55 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Thu, 18 Aug 2022 16:14:52 +1200 Subject: [PATCH 16/25] removing WIN32 from bindings --- src/bindings/c/arrays.f90 | 5 +---- src/bindings/c/exports.f90 | 4 ---- src/bindings/c/gas_exchange.f90 | 9 --------- src/bindings/c/geometry.f90 | 25 +------------------------ src/bindings/c/growtree.f90 | 5 ----- src/bindings/c/surface_fitting.f90 | 8 -------- src/bindings/c/ventilation.f90 | 4 ---- 7 files changed, 2 insertions(+), 58 deletions(-) diff --git a/src/bindings/c/arrays.f90 b/src/bindings/c/arrays.f90 index 1345c8b5..d66e0c2a 100644 --- a/src/bindings/c/arrays.f90 +++ b/src/bindings/c/arrays.f90 @@ -39,11 +39,8 @@ subroutine update_parameter_c(parameter_name, parameter_name_len, parameter_valu character(len=max_filename_len) :: parameter_name_f call strncpy(parameter_name_f, parameter_name, parameter_name_len) -#if defined _WIN32 && defined __INTEL_COMPILER - call so_update_parameter(parameter_name_f, parameter_value) -#else call update_parameter(parameter_name_f, parameter_value) -#endif + end subroutine update_parameter_c diff --git a/src/bindings/c/exports.f90 b/src/bindings/c/exports.f90 index 349c04b6..480ceab4 100644 --- a/src/bindings/c/exports.f90 +++ b/src/bindings/c/exports.f90 @@ -24,11 +24,7 @@ subroutine export_cubic_lagrange_2d_c(EXFILE, filename_len, group_name, group_na call strncpy(filename_f, EXFILE, filename_len) call strncpy(group_name_f, group_name, group_name_len) -#if defined _WIN32 && defined __INTEL_COMPILER - call so_export_cubic_lagrange_2d(filename_f, group_name_f) -#else call export_cubic_lagrange_2d(filename_f, group_name_f) -#endif end subroutine export_cubic_lagrange_2d_c diff --git a/src/bindings/c/gas_exchange.f90 b/src/bindings/c/gas_exchange.f90 index bc32283d..5981b689 100644 --- a/src/bindings/c/gas_exchange.f90 +++ b/src/bindings/c/gas_exchange.f90 @@ -12,11 +12,7 @@ subroutine initial_gasexchange_c(initial_concentration,surface_area,V_cap) & !!! Parameter List real(dp),intent(in) :: initial_concentration,surface_area,V_cap -#if defined _WIN32 && defined __INTEL_COMPILER - call so_initial_gasexchange(initial_concentration,surface_area,V_cap) -#else call initial_gasexchange(initial_concentration,surface_area,V_cap) -#endif end subroutine initial_gasexchange_c @@ -31,13 +27,8 @@ subroutine steadystate_gasexchange_c(deadspace,p_i_o2,shunt_fraction, & real(dp),intent(in) :: deadspace,p_i_o2,shunt_fraction,target_p_art_co2, & target_p_ven_o2,VCO2,VO2 -#if defined _WIN32 && defined __INTEL_COMPILER - call so_steadystate_gasexchange(deadspace,p_i_o2,shunt_fraction, & - target_p_art_co2,target_p_ven_o2,VCO2,VO2) -#else call steadystate_gasexchange(deadspace,p_i_o2,shunt_fraction, & target_p_art_co2,target_p_ven_o2,VCO2,VO2) -#endif end subroutine steadystate_gasexchange_c diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index af9e80e6..d8c9f2f2 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -28,11 +28,8 @@ subroutine add_mesh_c(AIRWAY_MESHFILE, filename_len, BRANCHTYPE, branchtype_len, call strncpy(filename_f, AIRWAY_MESHFILE, filename_len) call strncpy(branchtype_f, BRANCHTYPE, branchtype_len) -#if defined _WIN32 && defined __INTEL_COMPILER - call so_add_mesh(filename_f, branchtype_f, n_refine) -#else + call add_mesh(filename_f, branchtype_f, n_refine) -#endif end subroutine add_mesh_c ! @@ -149,11 +146,7 @@ subroutine import_node_geometry_2d_c(NODEFILE, filename_len) bind(C, name="impor call strncpy(filename_f, NODEFILE, filename_len) -#if defined _WIN32 && defined __INTEL_COMPILER - call so_import_node_geometry_2d(filename_f) -#else call import_node_geometry_2d(filename_f) -#endif end subroutine import_node_geometry_2d_c @@ -182,11 +175,7 @@ subroutine make_data_grid_c(surface_elems_len, surface_elems, offset, spacing, & call strncpy(filename_f, filename, filename_len) call strncpy(groupname_f, groupname, groupname_len) -#if defined _WIN32 && defined __INTEL_COMPILER - call so_make_data_grid(surface_elems, offset, spacing, filename_f, groupname_f) -#else call make_data_grid(surface_elems, offset, spacing, filename_f, groupname_f) -#endif end subroutine make_data_grid_c @@ -331,11 +320,7 @@ subroutine refine_1d_elements_c(elemlist, elemlist_len, nrefinements) bind(C, na integer,intent(in) :: elemlist(elemlist_len) integer,intent(in) :: nrefinements -#if defined _WIN32 && defined __INTEL_COMPILER - call so_refine_1d_elements(elemlist, nrefinements) -#else call refine_1d_elements(elemlist, nrefinements) -#endif end subroutine refine_1d_elements_c @@ -347,11 +332,7 @@ subroutine renumber_tree_in_order_c() bind(C, name="renumber_tree_in_order_c") use geometry, only: renumber_tree_in_order implicit none -#if defined _WIN32 && defined __INTEL_COMPILER - call so_renumber_tree_in_order -#else call renumber_tree_in_order -#endif end subroutine renumber_tree_in_order_c @@ -370,11 +351,7 @@ subroutine initialise_lung_volume_c(Gdirn, COV, total_volume, Rmax, Rmin) bind(C integer,intent(in) :: Gdirn real(dp),intent(in) :: COV, total_volume, Rmax, Rmin -#if defined _WIN32 && defined __INTEL_COMPILER - call so_initialise_lung_volume(Gdirn, COV, total_volume, Rmax, Rmin) -#else call initialise_lung_volume(Gdirn, COV, total_volume, Rmax, Rmin) -#endif end subroutine initialise_lung_volume_c diff --git a/src/bindings/c/growtree.f90 b/src/bindings/c/growtree.f90 index 09abfe6c..219b1b66 100644 --- a/src/bindings/c/growtree.f90 +++ b/src/bindings/c/growtree.f90 @@ -29,13 +29,8 @@ subroutine grow_tree_c(surface_elems_len, surface_elems, parent_ne, & real(dp),intent(in) :: shortest_length real(dp),intent(in) :: rotation_limit -#if defined _WIN32 && defined __INTEL_COMPILER - call so_grow_tree(surface_elems, parent_ne, angle_max, angle_min, branch_fraction, length_limit,& -shortest_length, rotation_limit) -#else call grow_tree(surface_elems, parent_ne, angle_max, angle_min, branch_fraction, length_limit,& shortest_length, rotation_limit) -#endif end subroutine grow_tree_c diff --git a/src/bindings/c/surface_fitting.f90 b/src/bindings/c/surface_fitting.f90 index e374b122..6db576e3 100644 --- a/src/bindings/c/surface_fitting.f90 +++ b/src/bindings/c/surface_fitting.f90 @@ -21,11 +21,7 @@ subroutine fit_surface_geometry_c(niterations, fitting_file, filename_len) & call strncpy(filename_f, fitting_file, filename_len) -#if defined _WIN32 && defined __INTEL_COMPILER - call so_fit_surface_geometry(niterations, filename_f) -#else call fit_surface_geometry(niterations, filename_f) -#endif end subroutine fit_surface_geometry_c @@ -35,11 +31,7 @@ subroutine initialise_fit_mesh_c() bind(C, name="initialise_fit_mesh_c") use surface_fitting, only: initialise_fit_mesh implicit none -#if defined _WIN32 && defined __INTEL_COMPILER - call so_initialise_fit_mesh -#else call initialise_fit_mesh -#endif end subroutine initialise_fit_mesh_c diff --git a/src/bindings/c/ventilation.f90 b/src/bindings/c/ventilation.f90 index 7d7b51dd..f2e05b04 100644 --- a/src/bindings/c/ventilation.f90 +++ b/src/bindings/c/ventilation.f90 @@ -15,11 +15,7 @@ subroutine evaluate_vent_c(num_breaths, dt) bind(C, name="evaluate_vent_c") integer, intent(in) :: num_breaths real(dp), intent(in) :: dt -#if defined _WIN32 && defined __INTEL_COMPILER - call so_evaluate_vent(num_breaths, dt) -#else call evaluate_vent(num_breaths, dt) -#endif end subroutine evaluate_vent_c From 92525052bdd700fb25585a0af4f0fbc872a0f6f4 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 10:31:24 +1200 Subject: [PATCH 17/25] removed changes to gas_exchange.* in bindings. removed all changes to gas_exchange in lib --- src/bindings/c/gas_exchange.c | 20 ++-- src/bindings/c/gas_exchange.f90 | 41 +++----- src/bindings/c/gas_exchange.h | 3 +- src/bindings/interface/gas_exchange.i | 3 - src/lib/gas_exchange.f90 | 146 ++++++-------------------- 5 files changed, 57 insertions(+), 156 deletions(-) diff --git a/src/bindings/c/gas_exchange.c b/src/bindings/c/gas_exchange.c index b91b8ead..d2ec251a 100644 --- a/src/bindings/c/gas_exchange.c +++ b/src/bindings/c/gas_exchange.c @@ -1,18 +1,12 @@ - #include "gas_exchange.h" -void initial_gasexchange_c(double *initial_concentration, double *surface_area, double *V_cap); - -void steadystate_gasexchange_c(double *deadspace, double *p_i_o2, double *shunt_fraction, double *target_p_art_co2, double *target_p_ven_o2, double *VCO2, double *VO2); +void steadystate_gasexchange_c(double *c_art_o2, double *c_ven_o2, + double *p_art_co2, double *p_art_o2, double *p_i_o2, double *p_ven_co2, double *p_ven_o2, double *shunt_fraction, + double *VCO2, double *VO2); - -void initial_gasexchange(double initial_concentration, double surface_area, double V_cap) +void steadystate_gasexchange(double *c_art_o2, double *c_ven_o2, + double *p_art_co2, double *p_art_o2, double *p_i_o2, double *p_ven_co2, double *p_ven_o2, double *shunt_fraction, + double *VCO2, double *VO2) { - initial_gasexchange_c(&initial_concentration, &surface_area, &V_cap); + steadystate_gasexchange_c(c_art_o2, c_ven_o2, p_art_co2, p_art_o2, p_i_o2, p_ven_co2, p_ven_o2, shunt_fraction, VCO2, VO2); } - -void steadystate_gasexchange(double deadspace, double p_i_o2, double shunt_fraction, double target_p_art_co2, double target_p_ven_o2, double VCO2, double VO2) -{ - steadystate_gasexchange_c(&deadspace, &p_i_o2, &shunt_fraction, &target_p_art_co2, &target_p_ven_o2, &VCO2, &VO2); -} - diff --git a/src/bindings/c/gas_exchange.f90 b/src/bindings/c/gas_exchange.f90 index 5981b689..800f69b7 100644 --- a/src/bindings/c/gas_exchange.f90 +++ b/src/bindings/c/gas_exchange.f90 @@ -1,38 +1,27 @@ module gas_exchange_c implicit none private - + contains !!!###################################################################### - subroutine initial_gasexchange_c(initial_concentration,surface_area,V_cap) & - bind(C, name="initial_gasexchange_c") - use gas_exchange,only: initial_gasexchange - use arrays,only: dp - implicit none - !!! Parameter List - real(dp),intent(in) :: initial_concentration,surface_area,V_cap - - call initial_gasexchange(initial_concentration,surface_area,V_cap) - - end subroutine initial_gasexchange_c - -!!!###################################################################### - subroutine steadystate_gasexchange_c(deadspace,p_i_o2,shunt_fraction, & - target_p_art_co2,target_p_ven_o2,VCO2,VO2) bind(C, name="steadystate_gasexchange_c") + subroutine steadystate_gasexchange_c(c_art_o2,c_ven_o2,& + p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& + VCO2,VO2) bind(C, name="steadystate_gasexchange_c") use gas_exchange, only: steadystate_gasexchange use arrays,only: dp implicit none - + !!! Parameter List - real(dp),intent(in) :: deadspace,p_i_o2,shunt_fraction,target_p_art_co2, & - target_p_ven_o2,VCO2,VO2 - - call steadystate_gasexchange(deadspace,p_i_o2,shunt_fraction, & - target_p_art_co2,target_p_ven_o2,VCO2,VO2) - + real(dp),intent(in) :: p_i_o2,shunt_fraction,VCO2,VO2 + real(dp), intent(inout) :: c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_ven_o2,p_ven_co2 + + call steadystate_gasexchange(c_art_o2,c_ven_o2,& + p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& + VCO2,VO2) + end subroutine steadystate_gasexchange_c - - - + + + end module gas_exchange_c diff --git a/src/bindings/c/gas_exchange.h b/src/bindings/c/gas_exchange.h index 4dade84f..c727b417 100644 --- a/src/bindings/c/gas_exchange.h +++ b/src/bindings/c/gas_exchange.h @@ -3,7 +3,6 @@ #include "symbol_export.h" -SHO_PUBLIC void initial_gasexchange(double initial_concentration, double surface_area, double V_cap); -SHO_PUBLIC void steadystate_gasexchange(double deadspace, double p_i_o2, double shunt_fraction, double target_p_art_co2, double target_p_ven_o2, double VCO2, double VO2); +SHO_PUBLIC void steadystate_gasexchange(); #endif /* AETHER_GAS_EXCHANGE_H */ diff --git a/src/bindings/interface/gas_exchange.i b/src/bindings/interface/gas_exchange.i index 1cc76582..34467ed5 100644 --- a/src/bindings/interface/gas_exchange.i +++ b/src/bindings/interface/gas_exchange.i @@ -7,8 +7,5 @@ #include "gas_exchange.h" %} -void initial_gasexchange(double initial_concentration, double surface_area, double V_cap); -void steadystate_gasexchange(double deadspace, double p_i_o2, double shunt_fraction, double target_p_art_co2, double target_p_ven_o2, double VCO2, double VO2); - %include gas_exchange.h diff --git a/src/lib/gas_exchange.f90 b/src/lib/gas_exchange.f90 index 05ed7f47..1b00850b 100644 --- a/src/lib/gas_exchange.f90 +++ b/src/lib/gas_exchange.f90 @@ -67,7 +67,7 @@ module gas_exchange ! subroutine initial_gasexchange(initial_concentration,surface_area,V_cap) !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIAL_GASEXCHANGE" :: INITIAL_GASEXCHANGE - + !local variables real(dp),intent(in) :: initial_concentration real(dp), optional :: surface_area,V_cap @@ -129,86 +129,7 @@ end subroutine initial_gasexchange !!! ###################################################################### - subroutine steadystate_gasexchange(Vdot_deadspace,p_i_o2,shunt_fraction, & - target_p_art_co2,target_p_ven_o2,VCO2,VO2) - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_STEADYSTATE_GASEXCHANGE" :: STEADYSTATE_GASEXCHANGE - - use field_utilities,only: scale_flow_to_inlet - -!!! Parameters - real(dp),intent(in) :: Vdot_deadspace,p_i_o2,shunt_fraction, & - target_p_art_co2,target_p_ven_o2,VCO2,VO2 -!!! Local variables - integer :: k,nunit - real(dp) :: cardiac_temp,c_art_o2,c_ven_o2,Vdot_alv_temp - real(dp) :: p_art_co2,p_art_o2,p_ven_co2,p_ven_o2 - character(len=60) :: sub_name - - sub_name = 'steadystate_gasexchange' - call enter_exit(sub_name,1) - - cardiac_temp = elem_field(ne_Qdot,1) - Vdot_alv_temp = elem_field(ne_Vdot,1) - Vdot_deadspace - - !temporarily scale the flow to alveolar ventilation - call scale_flow_to_inlet(Vdot_alv_temp,'V') - call steadystate_gasexchange_sub (c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_i_o2,& - p_ven_co2,p_ven_o2,shunt_fraction,VCO2,VO2) - -!!! in the following loop the alveolar ventilation is incrementally adjusted -!!! towards achieving the target p_art_co2; and the cardiac output is adjusted -!!! to balance the metabolic demand for oxygen. - k = 0 - do while (abs(p_art_co2-target_p_art_co2)/target_p_art_co2 .gt. 1.0e-4_dp ) - k = k + 1 - - Vdot_alv_temp = p_art_co2/target_p_art_co2*Vdot_alv_temp - call scale_flow_to_inlet(Vdot_alv_temp,'V') - call steadystate_gasexchange_sub (c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_i_o2,& - p_ven_co2,p_ven_o2,shunt_fraction,VCO2,VO2) - if(k.gt.200)then - write(*,'('' Exiting alveolar ventilation calculation: not converged in 200 iterations'')') - return - endif - end do - - write(*,'('' Alveolar ventilation = '',f8.3,'' L/min to match target P_art_CO2 of '',f8.3)') & - Vdot_alv_temp/1.0e+6_dp*60.0_dp,target_p_art_co2 - - k = 0 - do while (abs(p_ven_o2-target_p_ven_o2)/target_p_ven_o2 .gt. 1.0e-4_dp ) - k = k + 1 - - cardiac_temp = cardiac_temp * target_p_ven_o2/p_ven_o2 - call scale_flow_to_inlet(cardiac_temp,'Q') - call steadystate_gasexchange_sub (c_art_o2,c_ven_o2,p_art_co2,p_art_o2,p_i_o2,& - p_ven_co2,p_ven_o2,shunt_fraction,VCO2,VO2) - if(k.gt.200)then - write(*,'('' Exiting cardiac output calculation: not converged in 200 iterations'')') - return - endif - end do - if(k.le.200)then !converged -!!! update transit time through the gas exchange unit = capillary volume/flow - forall (nunit=1:num_units) gasex_field(ng_tt,nunit) = & - gasex_field(ng_Vc,nunit)/unit_field(nu_perf,nunit)/& - (cardiac_temp*(1.0_dp-shunt_fraction)) - endif - write(*,'('' Cardiac output = '',f8.3,'' L/min to match target P_ven_O2 of '',f7.2)') & - cardiac_temp/1.0e+6_dp*60.0_dp,target_p_ven_o2 - - ! scale the ventilation back to minute ventilation - Vdot_alv_temp = elem_field(ne_Vdot,1) + Vdot_deadspace - call scale_flow_to_inlet(Vdot_alv_temp,'V') - - call enter_exit(sub_name,2) - - end subroutine steadystate_gasexchange - -! -!########################################################################################### -! - subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& + subroutine steadystate_gasexchange(c_art_o2,c_ven_o2,& p_art_co2,p_art_o2,p_i_o2,p_ven_co2,p_ven_o2,shunt_fraction,& VCO2,VO2) @@ -221,14 +142,14 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& fun_co2,fdash,p_cap_co2,p_cap_o2,p_art_co2_last, & p_art_o2_last,p_ven_co2_last,p_ven_o2_last,Q_total,V_total, & target_c_ven_co2,target_c_ven_o2,v_q,p_alv_o2,p_alv_co2 - + real(dp),parameter :: m = 0.02386_dp, tol = 1.0e-6_dp logical :: continue character(len=60) :: sub_name - - sub_name = 'steadystate_gasexchange_sub' + + sub_name = 'steadystate_gasexchange' call enter_exit(sub_name,1) - + !!! Calculate steady state gas exchange for CO2 p_ven_co2_last = p_ven_co2 ! updates at each iteration, until converged counter = 1 ! count the number of iterations @@ -242,13 +163,13 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& p_cap_co2 = gasex_field(ng_p_cap_co2,nunit) ! initialise capillary CO2 v_q = unit_field(nu_Vdot0,nunit) & /unit_field(nu_perf,nunit) ! the unit v/q - if(abs(v_q) .le. 1.0e-3_dp)then ! no ventilation; cap CO2 == venous CO2 + if(dabs(v_q) .le. 1.0e-3_dp)then ! no ventilation; cap CO2 == venous CO2 p_cap_co2 = p_ven_co2 else ! calculate the steady-state PCO2 fun_co2 = function_co2(v_q,p_cap_co2,p_ven_co2) fdash = fdash_co2(v_q,p_cap_co2) K=0 - do while(abs(fun_co2).ge.1.0e-4_dp.and.(k.LT.200)) + do while(dabs(fun_co2).ge.1.0e-4_dp.and.(k.LT.200)) K=K+1 p_cap_co2 = p_cap_co2 - fun_CO2/fdash fun_co2 = function_co2(v_q,p_cap_co2,p_ven_co2) @@ -256,8 +177,8 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& enddo endif - Q_total = Q_total + elem_units_below(ne) * abs(unit_field(nu_perf,nunit)) !mm3/s - V_total = V_total + elem_units_below(ne) * abs(unit_field(nu_Vdot0,nunit)) + Q_total = Q_total + elem_units_below(ne) * dabs(unit_field(nu_perf,nunit)) !mm3/s + V_total = V_total + elem_units_below(ne) * dabs(unit_field(nu_Vdot0,nunit)) !!! including a limitation that p_cap_co2 cannot be less than zero p_cap_co2 = max(p_cap_co2,0.0_dp) @@ -270,10 +191,10 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& c_cap_co2 = m*p_cap_co2/(1 + m*p_cap_co2) !!! sum the content in arterial blood (flow weighted sum) c_art_co2 = c_art_co2 + elem_units_below(ne)* & - (c_cap_co2*abs(unit_field(nu_perf,nunit))) !flow-weighted + (c_cap_co2*dabs(unit_field(nu_perf,nunit))) !flow-weighted !! sum the alveolar co2 p_alv_co2=p_alv_co2 + elem_units_below(ne)* & - (p_cap_co2*abs(unit_field(nu_Vdot0,nunit))) !flow-weighted + (p_cap_co2*dabs(unit_field(nu_Vdot0,nunit))) !flow-weighted enddo !nunit !!! update the arterial content of CO2 @@ -288,7 +209,7 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& p_art_co2 = 1/(m*(1-c_art_co2)) ! initialise p_art_co2 K=0 !counter fun_co2 = m*p_art_co2/(1+m*p_art_co2)-c_art_co2 - do while (abs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) + do while (dabs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) K=K+1 fdash=m/(1+m*p_art_co2)**2 p_art_co2 = p_art_co2 - fun_co2/fdash @@ -300,18 +221,18 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& p_ven_co2 = 1/(m*(1-target_c_ven_co2)) K=0 fun_co2=m*p_ven_co2/(1+m*p_ven_co2)-target_c_ven_CO2 - do while (abs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) + do while (dabs(fun_co2).ge.1.0e-4_dp.and.(k.lt.200)) K=K+1 fdash=m/(1+m*p_ven_co2)**2 p_ven_co2 = p_ven_co2-fun_co2/fdash fun_co2 = m*p_ven_co2/(1+m*p_ven_co2)-target_c_ven_co2 enddo !while !!! now have updated values for p_art_co2 and p_ven_co2 - !write(*,'('' Interim PPs:'',4(f8.3))') p_art_o2,p_ven_o2,p_art_co2,p_ven_co2 + write(*,'('' Interim PPs:'',4(f8.3))') p_art_o2,p_ven_o2,p_art_co2,p_ven_co2 !!! check whether p_ven_co2 and p_art_co2 have converged if(counter.gt.1)then - if(abs(p_ven_co2-p_ven_co2_last)/p_ven_co2_last.lt.tol.and. & - abs(p_art_co2-p_art_co2_last)/p_art_co2_last.lt.tol) then + if(dabs(p_ven_co2-p_ven_co2_last)/p_ven_co2_last.lt.tol.and. & + dabs(p_art_co2-p_art_co2_last)/p_art_co2_last.lt.tol) then continue = .false. else if(counter.gt.200) continue = .false. @@ -326,13 +247,14 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& endif enddo !while continue +! read(*,*) - write(*,'('' Cardiac output ='',F8.3,'' L/min, alveolar ventilation ='',F8.3,'' L/min'')') & - Q_total/1.0e+6_dp*60.0_dp,V_total/1.0e+6_dp*60.0_dp - write(*,'('' Steady-state P_art_CO2 ='',F6.1,'' mmHg,& + write(*,'('' Total blood flow ='',F10.1,'' mm3/s,& + & alveolar ventilation='',F10.1,'' mm3/s'')') Q_total,V_total + write(*,'('' Steady-state P_art_CO2 ='',F6.1,'' mmHg,& & P_ven_CO2='',F6.1,'' mmHg'')') p_art_co2,p_ven_co2 write(*,'('' P_alv_CO2 ='',F6.1,'' mmHg,& - & P(A-a)CO2='',F6.1,'' mmHg'')') p_alv_co2,p_alv_co2-p_art_co2 + & P(A-a)CO2='',F6.1,'' mmHg'')') p_alv_co2,p_alv_co2-p_art_co2 !!! Calculate steady state gas exchange for O2 p_ven_o2_last = p_ven_o2 @@ -371,10 +293,10 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& c_cap_o2 = content_from_po2(p_cap_co2,p_cap_o2) !!! sum the content in arterial blood (flow weighted sum) c_art_o2 = c_art_o2 + elem_units_below(ne)* & - (c_cap_o2*abs(unit_field(nu_perf,nunit))) !flow-weighted + (c_cap_o2*dabs(unit_field(nu_perf,nunit))) !flow-weighted !! sum the alveolar o2 p_alv_o2=p_alv_o2 + elem_units_below(ne)* & - (p_cap_o2*abs(unit_field(nu_Vdot0,nunit))) !flow-weighted + (p_cap_o2*dabs(unit_field(nu_Vdot0,nunit))) !flow-weighted ! write(*,*) 'V/Q=',v_q,' pO2=',p_cap_o2,c_cap_o2,c_art_o2 enddo !nunit @@ -436,7 +358,7 @@ subroutine steadystate_gasexchange_sub(c_art_o2,c_ven_o2,& call enter_exit(sub_name,2) - end subroutine steadystate_gasexchange_sub + end subroutine steadystate_gasexchange !!! #################################################### @@ -521,7 +443,7 @@ function content_from_po2 (PCO2,po2) !!! Local variables real(dp) :: content_from_po2,ShbO2 - if(abs(po2).lt.zero_tol)then + if(dabs(po2).lt.zero_tol)then SHbO2 = 0.0_dp content_from_po2 = 0.0_dp else @@ -552,7 +474,7 @@ function saturation_of_o2 (PCO2,po2) A4=9.359609e+5_dp, A5=-3.134626e+4_dp, A6=2.396167e+3_dp, A7=-6.710441e+1_dp real(dp) :: saturation_of_o2,X,ShbO2 - if(abs(po2).lt.zero_tol)then + if(dabs(po2).lt.zero_tol)then SHbO2 = 0.0_dp else @@ -579,7 +501,7 @@ function po2_from_content(c_o2,p_co2) real(dp),parameter :: tolerance=1.0e-5_dp logical :: converged - if(abs(c_o2).lt.tolerance)then + if(dabs(c_o2).lt.tolerance)then po2_from_content = 0.0_dp else converged = .false. @@ -590,23 +512,23 @@ function po2_from_content(c_o2,p_co2) c_o2_old = 0.0_dp ! updated after each iteration from c_o2_new c_o2_new = content_from_po2(p_co2,p_o2_new) ! Check convergence - if(abs((c_o2_new - c_o2)/c_o2).lt.tolerance*c_o2) converged =.true. + if(dabs((c_o2_new - c_o2)/c_o2).lt.tolerance*c_o2) converged =.true. ! Loop to find PO2 value do while (.not.converged.and.(i.lt.max_iterations)) ! Modify increment size if(c_o2_new.gt.c_o2)then - inc = -abs(inc) + inc = -dabs(inc) elseif(c_o2_new.lt.c_o2)then - inc = abs(inc) + inc = dabs(inc) endif if(i.gt.1)then diff_new = c_o2_new - c_o2 diff_old = c_o2_old - c_o2 - diff_step = abs(c_o2_new-c_o2_old) + diff_step = dabs(c_o2_new-c_o2_old) if((diff_old.gt.0.0_dp.and.diff_new.lt.0.0_dp).or. & (diff_old.lt.0.0_dp.and.diff_new.gt.0.0_dp))then ! the last 2 steps straddle point inc=inc/2.0_dp - elseif(abs(diff_new).gt.diff_step)THEN + elseif(dabs(diff_new).gt.diff_step)THEN inc=inc*2.0_dp endif endif @@ -617,7 +539,7 @@ function po2_from_content(c_o2,p_co2) p_o2_new = p_o2_new + inc c_o2_new = content_from_po2(p_co2,p_o2_new) ! Check convergence - if(abs((c_o2_new-c_o2)/c_o2).LT.tolerance*c_o2) converged = .true. + if(dabs((c_o2_new-c_o2)/c_o2).LT.tolerance*c_o2) converged = .true. i=i+1 From db6d91dba77b13dfdbcd957a22e776da318d4fc5 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 11:17:50 +1200 Subject: [PATCH 18/25] removed changes to add_mesh from bindings and lib --- src/bindings/c/geometry.c | 7 +- src/bindings/c/geometry.f90 | 10 +- src/bindings/c/geometry.h | 2 +- src/lib/geometry.f90 | 250 ++++++++++-------------------------- 4 files changed, 78 insertions(+), 191 deletions(-) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index 1336099c..da2576ee 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -3,7 +3,7 @@ #include "string.h" -void add_mesh_c(const char *AIRWAY_MESHFILE, int *filename_len, const char *BRANCHTYPE, int *branchtype_len, int *n_refine); +void add_mesh_c(const char *AIRWAY_MESHFILE, int *filename_len); void add_matching_mesh_c(void); void append_units_c(void); void define_1d_elements_c(const char *ELEMFILE, int *filename_len); @@ -30,11 +30,10 @@ void write_elem_geometry_2d_c(const char *ELEMFILE, int *filename_len); void write_geo_file_c(int *ntype, const char *GEOFILE, int *filename_len); void write_node_geometry_2d_c(const char *NODEFILE, int *filename_len); -void add_mesh(const char *AIRWAY_MESHFILE, const char *BRANCHTYPE, int n_refine ) +void add_mesh(const char *AIRWAY_MESHFILE) { int filename_len = (int)strlen(AIRWAY_MESHFILE); - int branchtype_len = (int)strlen(BRANCHTYPE); - add_mesh_c(AIRWAY_MESHFILE, &filename_len, BRANCHTYPE, &branchtype_len, &n_refine); + add_mesh_c(AIRWAY_MESHFILE, &filename_len); } void add_matching_mesh() diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index d8c9f2f2..e162eae1 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -14,22 +14,20 @@ module geometry_c !################################################################################### ! !*add_mesh:* Reads in an ipmesh file and adds this mesh to the terminal branches of an existing tree geometry - subroutine add_mesh_c(AIRWAY_MESHFILE, filename_len, BRANCHTYPE, branchtype_len, n_refine) bind(C, name="add_mesh_c") + subroutine add_mesh_c(AIRWAY_MESHFILE, filename_len) bind(C, name="add_mesh_c") use iso_c_binding, only: c_ptr use utils_c, only: strncpy use other_consts, only: MAX_FILENAME_LEN use geometry, only: add_mesh implicit none - integer,intent(in) :: filename_len, branchtype_len, n_refine - type(c_ptr), value, intent(in) :: AIRWAY_MESHFILE, BRANCHTYPE + integer,intent(in) :: filename_len + type(c_ptr), value, intent(in) :: AIRWAY_MESHFILE character(len=MAX_FILENAME_LEN) :: filename_f - character(len=MAX_FILENAME_LEN) :: branchtype_f call strncpy(filename_f, AIRWAY_MESHFILE, filename_len) - call strncpy(branchtype_f, BRANCHTYPE, branchtype_len) - call add_mesh(filename_f, branchtype_f, n_refine) + call add_mesh(filename_f) end subroutine add_mesh_c ! diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index bff48271..307cc151 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -4,7 +4,7 @@ #include "symbol_export.h" -SHO_PUBLIC void add_mesh(const char *AIRWAY_MESHFILE, const char *BRANCHTYPE, int n_refine); +SHO_PUBLIC void add_mesh(const char *AIRWAY_MESHFILE); SHO_PUBLIC void add_matching_mesh(); SHO_PUBLIC void append_units(); SHO_PUBLIC void define_1d_elements(const char *ELEMFILE); diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 5703f63f..36410df2 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -88,45 +88,33 @@ end subroutine allocate_node_arrays !!!############################################################################# - subroutine add_mesh(meshfile, branchtype, n_refine) + subroutine add_mesh(AIRWAY_MESHFILE) !*add_mesh:* Reads in an ipmesh file and adds this mesh to the terminal ! branches of an existing tree geometry - integer,intent(in) :: n_refine - character(len=*), intent(in) :: meshfile - character(len=*), intent(in) :: branchtype - logical :: scale_to_unit = .false. - - integer,dimension(1000) :: element_temp,generation,parent_element,symmetry_temp - integer :: i,ibeg,iend,i_ss_end,j,n,nbranch,ne,ne0,ne_global,ne_grandparent, & - ne_parent,ne_parent0, & - ne_start,ne_u,ne_u0,ngen_parent,nlabel,np,np0,np_global,ntype,num_elems_new, & - num_nodes_new,num_parents,num_elems_to_add,nunit - integer :: ios = 0 - integer :: line = 0 + character(len=MAX_FILENAME_LEN), intent(in) :: AIRWAY_MESHFILE + ! Local parameters + character(len=100) :: buffer integer, parameter :: fh = 15 - integer :: np1,np2 - integer, allocatable :: parentlist(:) - real(dp) :: ratio + integer :: ios + integer :: line + integer :: i,ibeg,iend,i_ss_end,j,ne,ne0,ne_global,ne_parent,ne_start, & + ngen_parent,np,np0,np_global,& + num_elems_new,num_elems_to_add,num_nodes_new,nunit,nlabel + integer,dimension(1000) :: element_temp,generation, & + parent_element,symmetry_temp real(dp),dimension(1000) :: length,radius,a_A - real(dp) :: A(3,3),B(3),branch_angle,direction(3),dirn_parent(3), & - dirn_grandparent(3),normal(3),normal2(3) - real(dp),allocatable :: volume_below(:) - character(len=100) :: buffer,readfile - - if(index(meshfile, ".ipmesh")> 0) then !full filename is given - readfile = meshfile - else ! need to append the correct filename extension - readfile = trim(meshfile)//'.ipmesh' - endif - open(fh, file=readfile) + character(len=60) :: sub_name - if(index(branchtype, "COND")>0 .or. index(branchtype, "cond")>0)then - ntype = 1 - elseif(index(branchtype, "RESP")>0 .or. index(branchtype, "resp")>0)then - ntype = 0 - endif + ! -------------------------------------------------------------------------- + + sub_name = 'add_mesh' + call enter_exit(sub_name,1) + ios = 0 + line = 0 + open(fh, file=AIRWAY_MESHFILE) + ! ios is negative if an end of record condition is encountered or if ! an endfile condition was detected. It is positive if an error was ! detected. ios is zero otherwise. @@ -136,7 +124,7 @@ subroutine add_mesh(meshfile, branchtype, n_refine) do while (ios == 0) read(fh, '(A)', iostat=ios) buffer - ! line contains: element, parent element, generation, + ! line contains: element, parent element, generation, ! symmetry, length, outer radius, a/A ratio ! note that a/A ratio is always 1 for the conducting airways if (ios == 0) then @@ -168,26 +156,14 @@ subroutine add_mesh(meshfile, branchtype, n_refine) endif enddo close(fh) - + num_elems_to_add = i - - allocate(parentlist(num_elems)) - parentlist = 0 - num_parents = 0 - do ne = 1,num_elems - if(elem_cnct(1,0,ne).eq.0)then - num_parents = num_parents + 1 - parentlist(num_parents) = ne - endif - enddo - - !num_parents = count(parentlist.ne.0) - + !!! increase the size of node and element arrays to accommodate the additional elements ! the number of nodes after adding mesh will be: - num_nodes_new = num_nodes + num_parents*num_elems_to_add*n_refine + num_nodes_new = num_nodes + num_units*num_elems_to_add ! the number of elems after adding mesh will be: - num_elems_new = num_elems + num_parents*num_elems_to_add*n_refine + num_elems_new = num_elems + num_units*num_elems_to_add call reallocate_node_elem_arrays(num_elems_new,num_nodes_new) ne = num_elems ! the starting local element number @@ -195,154 +171,68 @@ subroutine add_mesh(meshfile, branchtype, n_refine) np = num_nodes ! the starting local node number np_global = nodes(np) ! assumes this is the highest node number (!!!) - do nbranch = 1,num_parents ! for all listed branches, append the mesh + do nunit = 1,num_units ! for all terminal branches, append the mesh + + ne_parent = units(nunit) ! local element number of terminal, to append to + ngen_parent = elem_ordrs(1,ne_parent) ne_start = ne !starting element number for the unit - do i = 1,num_elems_to_add + do i=1,num_elems_to_add - if(parent_element(i).eq.0)then !first new elem to append; add to existing - ne_parent = parentlist(nbranch) ! local element number of terminal, to append to - ne_parent0 = ne_parent + if(parent_element(i).eq.0)then + ne_parent = units(nunit) else - ne_parent = ne_start+parent_element(i) & !adding to new - *n_refine !+(nunit-1)*num_elems_to_add*n_refine !!new line + ne_parent = ne_start+parent_element(i) endif - ngen_parent = elem_ordrs(1,ne_parent) ne0 = ne_parent - - ! for the branching angle and direction - - if(symmetry_temp(i).eq.1)then ! same as parent if symmetric - direction(:) = elem_direction(:,ne_parent) - elseif(nbranch.eq.1)then - direction(:) = elem_direction(:,ne_parent) - else - ne_grandparent = get_parent_branch(ne_parent) - dirn_parent(:) = elem_direction(:,ne_parent) - if(ne_grandparent.eq.0)then - normal(1) = 0.0_dp - normal(2) = -1.0_dp/sqrt(2.0_dp) - normal(3) = 1.0_dp/sqrt(2.0_dp) - else - dirn_grandparent(:) = elem_direction(:,ne_grandparent) - if(check_vectors_same(dirn_parent,dirn_grandparent))then - normal(1) = 0.0_dp - normal(2) = -1.0_dp/sqrt(2.0_dp) - normal(3) = 1.0_dp/sqrt(2.0_dp) - else - normal = cross_product(dirn_parent,dirn_grandparent) !get normal to parent-grandparent - normal = unit_vector(normal) ! normalise - endif - endif - branch_angle = 25.0_dp * pi/180.0_dp - normal2 = cross_product(dirn_parent,normal) ! equation for the branching plane - normal2 = unit_vector(normal2) ! normalise - ! set up a mini linear system to solve: - A(1,:) = dirn_parent(:) !dotprod parent and new element - A(2,:) = normal(:) !dotprod normal and new element - A(3,:) = normal2(:) !dotprod plane and new element - B(1) = cos(branch_angle) !angle between parent & element - - if(elem_cnct(1,0,ne_parent).eq.0)then ! is the first child branch - B(2) = cos(pi/2.0_dp - branch_angle) !angle btwn normal & element - else !for second child - B(2) = cos(pi/2.0_dp + branch_angle) !angle btwn normal & element - endif - B(3) = 0.0_dp !on plane:(w-p).nrml=const;nrml.p=const + np0 = elem_nodes(2,ne0) - direction = mesh_a_x_eq_b(A,B) !solve ax=b - direction = unit_vector(direction) - endif + ne_global = ne_global + 1 ! new global element number + ne = ne + 1 ! new local element number + np_global = np_global + 1 !new global node number + np = np + 1 ! new local node number + + nodes(np) = np_global + elems(ne) = ne_global + + elem_nodes(1,ne) = np0 + elem_nodes(2,ne) = np + + elem_ordrs(1,ne) = ngen_parent + generation(i) + elem_ordrs(no_type,ne) = 1 ! ntype ! 0 for respiratory, 1 for conducting + elem_symmetry(ne) = symmetry_temp(i)+1 ! uses 0/1 in file; 1/2 in code + + ! record the element connectivity + elem_cnct(-1,0,ne) = 1 ! one parent branch + elem_cnct(-1,1,ne) = ne0 ! store parent element + elem_cnct(1,0,ne0) = elem_cnct(1,0,ne0) + 1 + elem_cnct(1,elem_cnct(1,0,ne0),ne0) = ne + + ! record the direction and location of the branch + do j=1,3 + elem_direction(j,ne) = elem_direction(j,ne0) + node_xyz(j,np) = node_xyz(j,np0) + & + elem_direction(j,ne)*length(i) + enddo !j + + elem_field(ne_length,ne) = length(i) + elem_field(ne_radius,ne) = radius(i) + elem_field(ne_a_A,ne) = a_A(i) + elem_field(ne_vol,ne) = PI*radius(i)**2*length(i) - do n = 1,n_refine - - np0 = elem_nodes(2,ne0) - - ne_global = ne_global + 1 ! new global element number - ne = ne + 1 ! new local element number - np_global = np_global + 1 !new global node number - np = np + 1 ! new local node number - - nodes(np) = np_global - elems(ne) = ne_global - - elem_nodes(1,ne) = np0 - elem_nodes(2,ne) = np - - elem_ordrs(no_gen,ne) = ngen_parent + 1 !generation(i) - elem_ordrs(no_type,ne) = ntype ! 0 for respiratory, 1 for conducting - - if(n.eq.1)then - elem_symmetry(ne) = symmetry_temp(i)+1 ! uses 0/1 in file; 1/2 in code - else - elem_symmetry(ne) = 1 !not symmetric if a refined branch - endif - - ! record the element connectivity - elem_cnct(-1,0,ne) = 1 ! one parent branch - elem_cnct(-1,1,ne) = ne0 ! store parent element - elem_cnct(1,0,ne0) = elem_cnct(1,0,ne0) + 1 - elem_cnct(1,elem_cnct(1,0,ne0),ne0) = ne - - ! record the direction and location of the branch - do j=1,3 - elem_direction(j,ne) = direction(j) !!! WAS parent_direction(j) - node_xyz(j,np) = node_xyz(j,np0) + & - elem_direction(j,ne)*length(i)/dble(n_refine) - enddo !j - - elem_field(ne_length,ne) = length(i)/dble(n_refine) - elem_field(ne_radius,ne) = radius(i) - elem_field(ne_a_A,ne) = a_A(i) - - elem_field(ne_vol,ne) = pi*radius(i)**2 * length(i)/dble(n_refine) - - ne0 = ne - enddo !n enddo !i - - if(scale_to_unit)then - allocate(volume_below(ne)) - volume_below = 0.0_dp -!!! scale the mesh branch sizes such that total volume is the same as the unit volume - ! elements in unit are from ne_start+1 to ne - volume_below(ne_start+1:ne) = elem_field(ne_vol,ne_start+1:ne) ! initialise - do ne_u = ne,ne_start+1,-1 - ne_u0 = elem_cnct(-1,1,ne_u) - volume_below(ne_u0) = volume_below(ne_u0) & - + dble(elem_symmetry(ne_u))*volume_below(ne_u) - enddo - nunit = where_inlist(ne_parent0,units) - ratio = unit_field(nu_vol,nunit)/volume_below(ne_parent0) - elem_field(ne_vol,ne_start+1:ne) = elem_field(ne_vol,ne_start+1:ne)*ratio - -!!! scale the length and radius by the cube root of volume ratio - do ne_u = ne_start+1,ne ! scale both the length and the radius - elem_field(ne_radius,ne_u) = elem_field(ne_radius,ne_u)*ratio**0.333_dp - elem_field(ne_length,ne_u) = elem_field(ne_length,ne_u)*ratio**0.333_dp - enddo -!!! move the nodes to match the length scaling - do ne_u = ne_start,ne - np1 = elem_nodes(1,ne_u) - np2 = elem_nodes(2,ne_u) - node_xyz(:,np2) = node_xyz(:,np1) + elem_field(ne_length,ne_u) * & - elem_direction(:,ne_u) - enddo - - deallocate(volume_below) - endif - enddo !nunit num_nodes = np num_elems = ne - + call element_connectivity_1d - - deallocate(parentlist) + call evaluate_ordering ! calculate new ordering of tree + + call enter_exit(sub_name,2) end subroutine add_mesh - !!!############################################################################# From 0a3934c0efafd9a01fd2532bb1058a395550acc5 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 11:26:56 +1200 Subject: [PATCH 19/25] removed refine_1d_elements and renumber_tree_in_order from bindings and lib --- src/bindings/c/geometry.c | 12 -- src/bindings/c/geometry.f90 | 28 ----- src/bindings/c/geometry.h | 2 - src/lib/geometry.f90 | 228 ------------------------------------ 4 files changed, 270 deletions(-) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index da2576ee..d3c91d7a 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -22,8 +22,6 @@ void define_rad_from_geom_c(const char *order_system, int *order_system_len, dou const char *group_type, int *group_type_len, const char *group_options, int *group_options_len); void element_connectivity_1d_c(void); void evaluate_ordering_c(void); -void refine_1d_elements_c(int *elemlist_len, int elemlist[], int *nrefinements); -void renumber_tree_in_order_c(void); void initialise_lung_volume_c(int *Gdirn, double *COV, double *total_volume, double *Rmax, double *Rmin); void volume_of_mesh_c(double *volume_model, double *volume_tree); void write_elem_geometry_2d_c(const char *ELEMFILE, int *filename_len); @@ -136,16 +134,6 @@ void evaluate_ordering() evaluate_ordering_c(); } -void refine_1d_elements(int elemlist_len, int elemlist[], int nrefinements) -{ - refine_1d_elements_c(&elemlist_len, elemlist, &nrefinements); -} - -void renumber_tree_in_order() -{ - renumber_tree_in_order_c(); -} - void initialise_lung_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin) { initialise_lung_volume_c(&Gdirn, &COV, &total_volume, &Rmax, &Rmin); diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index e162eae1..16706d58 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -306,34 +306,6 @@ subroutine evaluate_ordering_c() bind(C, name="evaluate_ordering_c") end subroutine evaluate_ordering_c -! -!################################################################################### -! - - subroutine refine_1d_elements_c(elemlist, elemlist_len, nrefinements) bind(C, name="refine_1d_elements_c") - use geometry, only: refine_1d_elements - implicit none - - integer,intent(in) :: elemlist_len - integer,intent(in) :: elemlist(elemlist_len) - integer,intent(in) :: nrefinements - - call refine_1d_elements(elemlist, nrefinements) - - end subroutine refine_1d_elements_c - -! -!################################################################################### -! -! - subroutine renumber_tree_in_order_c() bind(C, name="renumber_tree_in_order_c") - use geometry, only: renumber_tree_in_order - implicit none - - call renumber_tree_in_order - - end subroutine renumber_tree_in_order_c - !################################################################################### ! !>*initialise_lung_volume:* assigns a volume to terminal units appended on a tree structure diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index 307cc151..f4bd9c82 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -22,8 +22,6 @@ SHO_PUBLIC void define_rad_from_geom(const char *ORDER_SYSTEM, double CONTROL_PA double START_RAD, const char *GROUP_TYPE, const char *GROUP_OPTIONS); SHO_PUBLIC void element_connectivity_1d(); SHO_PUBLIC void evaluate_ordering(); -SHO_PUBLIC void refine_1d_elements(int elemlist_len, int elemlist[], int nrefinements); -SHO_PUBLIC void renumber_tree_in_order(); SHO_PUBLIC void initialise_lung_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin); SHO_PUBLIC void volume_of_mesh(double *volume_model, double *volume_tree); SHO_PUBLIC void write_elem_geometry_2d(const char *ELEMFILE); diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 36410df2..19b2b25a 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -47,8 +47,6 @@ module geometry public make_data_grid public make_2d_vessel_from_1d public reallocate_node_elem_arrays - public refine_1d_elements - public renumber_tree_in_order public initialise_lung_volume public triangles_from_surface public volume_of_mesh @@ -3513,232 +3511,6 @@ subroutine geo_node_offset(node_xyz_offset) end subroutine geo_node_offset -!!!############################################################################# - - subroutine refine_1d_elements(elem_list_refine,num_refinements) -!!! Refines all elements from 1 up to num_elem_refine. Should be doing -!!! this for a list of specific elements only. - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_REFINE_1D_ELEMENTS :: REFINE_1D_ELEMENTS - - integer,intent(in) :: elem_list_refine(:) - integer,intent(in) :: num_refinements - - integer, allocatable :: node_list (:,:),new_units(:),temp_elem_units_below(:) - - integer :: num_elem_refine,i,ne,ne_new,node_end,node_start,np_new,& - nunits,num_elems_new,num_nodes_new,n_refine - real(dp) :: increment(3),refined_length - - num_elem_refine = count(elem_list_refine.ne.0) - - allocate(node_list(2,num_elems)) - node_list(1:2,1:num_elems) = elem_nodes(1:2,1:num_elems) - - num_nodes_new = num_nodes + num_refinements*num_elem_refine - num_elems_new = num_elems + num_refinements*num_elem_refine - - if(num_units.gt.0)then - allocate(new_units(num_units)) - new_units = 0 - nunits = 0 - allocate(temp_elem_units_below(num_elems_new)) - temp_elem_units_below(1:num_elems) = elem_units_below(1:num_elems) - endif - - call reallocate_node_elem_arrays(num_elems_new,num_nodes_new) - - np_new = num_nodes - ne_new = num_elems - - do i = 1,num_elem_refine - ne = elem_list_refine(i) - node_start = node_list(1,ne) - node_end = node_list(2,ne) - refined_length = elem_field(ne_length,ne)/dble(num_refinements+1) - increment(1:3) = elem_direction(1:3,ne)*refined_length - ! adjust the current element end node, length and volume - elem_nodes(2,ne) = np_new+1 - elem_field(ne_length,ne) = refined_length - elem_field(ne_vol,ne) = elem_field(ne_vol,ne)/dble(num_refinements+1) - - do n_refine = 1,num_refinements - np_new = np_new+1 - nodes(np_new) = np_new - node_xyz(1:3,np_new) = node_xyz(1:3,node_start) + increment(1:3) - - ne_new = ne_new+1 - elems(ne_new) = ne_new - elem_nodes(1,ne_new) = np_new - elem_nodes(2,ne_new) = np_new+1 ! is overwritten if 'last' element - - elem_field(ne_length,ne_new) = refined_length - elem_field(ne_radius,ne_new) = elem_field(ne_radius,ne) - elem_field(ne_vol,ne_new) = elem_field(ne_vol,ne) - elem_field(ne_vd_bel,ne_new) = elem_field(ne_vd_bel,ne) - elem_field(ne_vol,ne)*n_refine - elem_field(ne_vol_bel,ne_new) = elem_field(ne_vol_bel,ne) - elem_field(ne_vol,ne)*n_refine - elem_field(ne_a_A,ne_new) = elem_field(ne_a_A,ne) - elem_direction(1:3,ne_new) = elem_direction(1:3,ne) - elem_ordrs(1,ne_new) = elem_ordrs(1,ne) - if(num_units.gt.0) temp_elem_units_below(ne_new) = elem_units_below(ne) - node_start = np_new - - enddo - elem_nodes(2,ne_new) = node_end ! overwrites for just the 'last' element - enddo - - num_nodes = np_new - num_elems = ne_new - - if(num_units.gt.0)then - units = new_units - deallocate(elem_units_below) - allocate(elem_units_below(num_elems)) - elem_units_below = temp_elem_units_below - deallocate(new_units) - deallocate(temp_elem_units_below) - endif - - deallocate(node_list) - call element_connectivity_1d - elem_ordrs(no_type,:) = 1 ! 0 for respiratory, 1 for conducting - call renumber_tree_in_order - - end subroutine refine_1d_elements - -!!!############################################################################# - - subroutine renumber_tree_in_order - ! reorders a 1D tree network so that elements and nodes increase with order. - use math_utilities - - integer :: i,nchild,ne,ne0,ne_start,np,num_sorted,num_to_order,num_to_order_prev,& - nunit,old_ne,old_np - integer,allocatable :: elem_list(:),elem_back(:),elems_to_order(:), & - elems_to_order_next(:) - logical :: single - integer, allocatable :: temp_elem_ordrs(:,:),temp_elem_units_below(:), & - temp_elem_nodes(:,:),temp_elem_symmetry(:),temp_inv_node(:),temp_map_node(:) - real(dp),allocatable :: temp_elem_direction(:,:),temp_elem_field(:,:),temp_node_xyz(:,:) - - allocate (elem_list(num_elems)) - allocate (elem_back(num_elems)) - allocate (elems_to_order(num_elems)) - allocate (elems_to_order_next(num_elems)) - - ne_start = 1 ! this should be the stem element of current tree - elem_list(1) = ne_start ! the first element in the tree - elem_back(ne_start) = 1 - num_sorted = 0 - -!!! Set up the list of correctly ordered elements and nodes. - num_to_order = 1 - elems_to_order(1) = ne_start - do while(num_to_order.ne.0) !while still some to reorder - num_to_order_prev = num_to_order - num_to_order = 0 - do i = 1,num_to_order_prev !for parents in previous gen - ne0 = elems_to_order(i) - num_sorted = num_sorted+1 !increment counter - elem_list(num_sorted) = ne0 !store element # - elem_back(ne0) = num_sorted - single = .true. - do while (single) - if(elem_cnct(1,0,ne0).eq.1)then - ne = elem_cnct(1,1,ne0) !daughter element # - num_sorted = num_sorted+1 !increment counter - elem_list(num_sorted) = ne !store element # - elem_back(ne) = num_sorted - ne0 = ne - else if(elem_cnct(1,0,ne0).ge.2)then - do nchild = 1,elem_cnct(1,0,ne0) !for each child - ne = elem_cnct(1,nchild,ne0) !daughter element # - num_to_order = num_to_order+1 - elems_to_order_next(num_to_order) = ne - enddo !nchild - single = .false. - else if (elem_cnct(1,0,ne0).eq.0)then - single = .false. - endif - enddo !while - enddo !nz1 - elems_to_order = elems_to_order_next - enddo !while - -!!! Put values into temporary arrays; move to correct array positions. -!!! Assumes that new element and node numbering will start from 1. - -!!! at this point temp_elem_list has the order that we want. now transfer to arrays - allocate(temp_elem_ordrs(num_ord,num_elems)) - if(num_units.gt.0)then - allocate(temp_elem_units_below(num_elems)) - endif - allocate(temp_elem_nodes(2,num_elems)) - allocate(temp_elem_direction(3,num_elems)) - allocate(temp_elem_field(num_ne,num_elems)) - allocate(temp_elem_symmetry(num_elems)) - allocate(temp_inv_node(num_nodes)) - allocate(temp_map_node(num_nodes)) - allocate(temp_node_xyz(1:3,num_nodes)) - - temp_map_node(1) = 1 - temp_inv_node(1) = 1 - - do ne = 1,num_elems - old_ne = elem_list(ne) - temp_elem_ordrs(1:4,ne) = elem_ordrs(1:4,old_ne) - temp_elem_direction(1:3,ne) = elem_direction(1:3,old_ne) - temp_elem_field(:,ne) = elem_field(:,old_ne) - temp_elem_symmetry(ne) = elem_symmetry(old_ne) - temp_map_node(ne+1) = elem_nodes(2,old_ne) - temp_inv_node(elem_nodes(2,old_ne)) = ne+1 - if(num_units.gt.0)then - temp_elem_units_below(ne) = elem_units_below(old_ne) - endif - enddo - -!!! map the unordered node info to temporary node arrays - temp_node_xyz(1:3,1) = node_xyz(1:3,1) - do ne = 1,num_elems - np = ne+1 - old_ne = elem_list(ne) - old_np = temp_map_node(np) - temp_node_xyz(1:3,np) = node_xyz(1:3,old_np) - temp_elem_nodes(1,ne) = temp_inv_node(elem_nodes(1,old_ne)) - temp_elem_nodes(2,ne) = temp_inv_node(elem_nodes(2,old_ne)) - enddo - - if(num_units.gt.0)then - do nunit = 1,num_units - old_ne = units(nunit) - ne = elem_back(old_ne) - units(nunit) = ne - enddo - elem_units_below = temp_elem_units_below - endif - elem_ordrs = temp_elem_ordrs - elem_nodes = temp_elem_nodes - elem_direction = temp_elem_direction - elem_field = temp_elem_field - node_xyz = temp_node_xyz - - call element_connectivity_1d - - deallocate(elem_list) - deallocate(elem_back) - deallocate(elems_to_order) - deallocate(elems_to_order_next) - deallocate(temp_elem_ordrs) - if(num_units.gt.0) deallocate(temp_elem_units_below) - deallocate(temp_elem_nodes) - deallocate(temp_elem_direction) - deallocate(temp_elem_field) - deallocate(temp_elem_symmetry) - deallocate(temp_inv_node) - deallocate(temp_map_node) - deallocate(temp_node_xyz) - - end subroutine renumber_tree_in_order - !!!############################################################################# subroutine reallocate_node_elem_arrays(num_elems_new,num_nodes_new) From 7ba445bf3e1c93d8cc5564d13396eef80f21ed9a Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 13:26:00 +1200 Subject: [PATCH 20/25] removing default arrays for defining parameters from arrays.f90 and update parameters from bindings and lib --- src/bindings/c/arrays.c | 6 --- src/bindings/c/arrays.f90 | 19 +------ src/bindings/c/arrays.h | 1 - src/lib/arrays.f90 | 111 ++------------------------------------ 4 files changed, 4 insertions(+), 133 deletions(-) diff --git a/src/bindings/c/arrays.c b/src/bindings/c/arrays.c index a9d3cc4a..7e7b8a14 100644 --- a/src/bindings/c/arrays.c +++ b/src/bindings/c/arrays.c @@ -3,16 +3,10 @@ #include "string.h" void set_node_field_value_c(int *row, int *col, double *value); -void update_parameter_c(const char *parameter_name, int *parameter_name_len, double *parameter_value); void set_node_field_value(int row, int col, double value) { set_node_field_value_c(&row, &col, &value); } -void update_parameter(const char *parameter_name, double parameter_value) -{ - int parameter_name_len = (int)strlen(parameter_name); - update_parameter_c(parameter_name, ¶meter_name_len, ¶meter_value); -} diff --git a/src/bindings/c/arrays.f90 b/src/bindings/c/arrays.f90 index d66e0c2a..8efb0e71 100644 --- a/src/bindings/c/arrays.f90 +++ b/src/bindings/c/arrays.f90 @@ -12,7 +12,7 @@ module arrays_c use arrays,only: dp implicit none - public set_node_field_value_c,update_parameter_c + public set_node_field_value_c contains subroutine set_node_field_value_c(row, col, value) bind(C, name="set_node_field_value_c") @@ -26,23 +26,6 @@ subroutine set_node_field_value_c(row, col, value) bind(C, name="set_node_field_ end subroutine set_node_field_value_c - subroutine update_parameter_c(parameter_name, parameter_name_len, parameter_value) bind(C, name="update_parameter_c") - use iso_c_binding, only: c_ptr - use utils_c, only: strncpy - use other_consts, only: max_filename_len - use arrays, only: update_parameter - implicit none - - integer, intent(in) :: parameter_name_len - real(dp), intent(in) :: parameter_value - type(c_ptr),value, intent(in) :: parameter_name - character(len=max_filename_len) :: parameter_name_f - - call strncpy(parameter_name_f, parameter_name, parameter_name_len) - call update_parameter(parameter_name_f, parameter_value) - - end subroutine update_parameter_c - end module arrays_c diff --git a/src/bindings/c/arrays.h b/src/bindings/c/arrays.h index 15495724..1468b841 100644 --- a/src/bindings/c/arrays.h +++ b/src/bindings/c/arrays.h @@ -5,6 +5,5 @@ #include "symbol_export.h" SHO_PUBLIC void set_node_field_value(int row, int col, double value); -SHO_PUBLIC void update_parameter(const char *parameter_name, double parameter_value); #endif /* AETHER_ARRAYS_H */ diff --git a/src/lib/arrays.f90 b/src/lib/arrays.f90 index ffca2ff9..503c8877 100644 --- a/src/lib/arrays.f90 +++ b/src/lib/arrays.f90 @@ -112,55 +112,13 @@ module arrays real(dp) :: elasticity_parameters(3)=0.0_dp end type elasticity_param - type default_fluid_properties + type fluid_properties real(dp) :: blood_viscosity = 0.33600e-02_dp ! Pa.s real(dp) :: blood_density = 0.10500e-02_dp ! kg/cm3 real(dp) :: air_viscosity = 1.8e-5_dp ! Pa.s real(dp) :: air_density = 1.146e-6_dp ! g.mm^-3 - end type default_fluid_properties + end type fluid_properties - type default_lung_mechanics - ! default values for Fung exponential, as per Tawhai et al (2009) - real(dp) :: a = 0.433_dp - real(dp) :: b = -0.611_dp - real(dp) :: c = 2500.0_dp - real(dp) :: refvol_ratio = 0.5_dp - real(dp) :: chest_wall_compliance = 2000.0_dp - end type default_lung_mechanics - - type default_lung_volumes - ! default values for the 'typical' upright lung - real(dp) :: frc = 3.0e+6_dp ! frc in mm3 - real(dp) :: Rmax = 0.79_dp ! ratio of density in non-dependent tissue to mean density - real(dp) :: Rmin = 1.29_dp ! ratio of density in dependent tissue to mean density - real(dp) :: COV = 0.1_dp ! coefficient of variation for density - end type default_lung_volumes - - type default_ventilation - ! default values for ventilation - real(dp) :: tidal_volume = 4.0e+5_dp ! mm^3 - real(dp) :: i_to_e_ratio = 1.0_dp ! dim. - real(dp) :: time_breath = 4.0_dp ! sec - real(dp) :: P_air_inlet = 0.0_dp ! Pa - real(dp) :: P_muscle_estimate = -98.0665_dp * 2.0_dp ! 2 cmH2O converted to Pa - real(dp) :: factor_P_muscle_insp = 1.0_dp ! multiplier to scale inspiratory pressure - real(dp) :: factor_P_muscle_expn = 1.0_dp ! multiplier to scale expiratory pressure - character(len=7) :: expiration_type = 'passive' - end type default_ventilation - - type default_ventilation_solver - ! default values for the iterative solution in ventilation code - integer :: num_iterations = 200 - real(dp) :: error_tolerance = 1.0e-08_dp - end type default_ventilation_solver - -!!! arrays that start with default values, updated during simulations - type(default_fluid_properties) :: fluid_properties - type(default_lung_mechanics) :: lung_mechanics - type(default_lung_volumes) :: lung_volumes - type(default_ventilation) :: ventilation_values - type(default_ventilation_solver) :: ventilation_solver - ! temporary, for debugging: real(dp) :: unit_before @@ -174,8 +132,7 @@ module arrays num_lines_2d, lines_2d, line_versn_2d, lines_in_elem, nodes_in_line, elems_2d, & elem_cnct_2d, elem_nodes_2d, elem_versn_2d, elem_lines_2d, elems_at_node_2d, arclength, & scale_factors_2d, fluid_properties, elasticity_vessels, admittance_param, & - elasticity_param, all_admit_param, lung_mechanics, lung_volumes, ventilation_values, & - ventilation_solver, update_parameter, & + elasticity_param, all_admit_param, & mesh_from_depvar, depvar_at_node, depvar_at_elem, SparseCol, SparseRow, update_resistance_entries, & SparseVal, RHS, prq_solution, solver_solution, FIX @@ -190,66 +147,4 @@ subroutine set_node_field_value(row, col, value) end subroutine set_node_field_value - subroutine update_parameter(parameter_name, parameter_value) - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_UPDATE_PARAMETER" :: UPDATE_PARAMETER - implicit none - real(dp), intent(in) :: parameter_value - character(len=*), intent(in) :: parameter_name - - select case(parameter_name) - -!!! fluid_properties - case('blood_viscosity') - fluid_properties%blood_viscosity = parameter_value - case('blood_density') - fluid_properties%blood_density = parameter_value - case('air_viscosity') - fluid_properties%air_viscosity = parameter_value - case('air_density') - fluid_properties%air_density = parameter_value - -!!! lung_volumes - case('COV') - lung_volumes%COV = parameter_value - case('FRC') - lung_volumes%FRC = parameter_value - case('Rmax') - lung_volumes%Rmax = parameter_value - case('Rmin') - lung_volumes%Rmin = parameter_value - -!!! lung_mechanics - case('chest_wall_compliance') - lung_mechanics%chest_wall_compliance = parameter_value - case('mech_a') - lung_mechanics%a = parameter_value - case('mech_b') - lung_mechanics%b = parameter_value - case('mech_c') - lung_mechanics%c = parameter_value - case('refvol_ratio') - lung_mechanics%refvol_ratio = parameter_value - -!!! ventilation_values - case('i_to_e_ratio') - ventilation_values%i_to_e_ratio = parameter_value - case('tidal_volume') - ventilation_values%tidal_volume = parameter_value - case('time_breath') - ventilation_values%time_breath = parameter_value - case('P_muscle_estimate') - ventilation_values%P_muscle_estimate = parameter_value - case('P_air_inlet') - ventilation_values%P_air_inlet = parameter_value - -!!! ventilation_solver - case('vent_error_tol') - ventilation_solver%error_tolerance = parameter_value - case('vent_num_iterations') - ventilation_solver%num_iterations = int(parameter_value) - - end select - - end subroutine update_parameter - end module arrays From 79e4f20ad7c18d5d7fe5f48355d3687ae4c51d20 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 13:27:53 +1200 Subject: [PATCH 21/25] removed DEC$ ATTRIBUTES from export_cubic_lagrange_2d --- src/lib/exports.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/lib/exports.f90 b/src/lib/exports.f90 index 97ced23e..5e9cc213 100644 --- a/src/lib/exports.f90 +++ b/src/lib/exports.f90 @@ -43,7 +43,6 @@ module exports subroutine export_cubic_lagrange_2d(EXFILE,groupname) !*export_cubic_lagrange_2d:* write our node and element structure for ! cubic lagrange mesh, converted from existing cubic Hermite mesh - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_EXPORT_CUBIC_LAGRANGE_2D" :: EXPORT_CUBIC_LAGRANGE_2D use geometry,only: coord_at_xi character(len=*) :: EXFILE From 2f639c21c5c20899f40ce13beab3a05fc7ea2a8b Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 13:30:40 +1200 Subject: [PATCH 22/25] removed all changes in ventilation.f90 and bindings. removed initialise_lung_volume from geometry.f90 and bindings, and added set_initial_volume back in --- src/bindings/c/geometry.c | 6 - src/bindings/c/geometry.f90 | 19 -- src/bindings/c/geometry.h | 1 - src/bindings/c/ventilation.c | 6 +- src/bindings/c/ventilation.f90 | 7 +- src/bindings/c/ventilation.h | 2 +- src/lib/geometry.f90 | 20 +- src/lib/ventilation.f90 | 505 ++++++++++++++++++++++----------- 8 files changed, 359 insertions(+), 207 deletions(-) diff --git a/src/bindings/c/geometry.c b/src/bindings/c/geometry.c index d3c91d7a..a69ddaed 100644 --- a/src/bindings/c/geometry.c +++ b/src/bindings/c/geometry.c @@ -22,7 +22,6 @@ void define_rad_from_geom_c(const char *order_system, int *order_system_len, dou const char *group_type, int *group_type_len, const char *group_options, int *group_options_len); void element_connectivity_1d_c(void); void evaluate_ordering_c(void); -void initialise_lung_volume_c(int *Gdirn, double *COV, double *total_volume, double *Rmax, double *Rmin); void volume_of_mesh_c(double *volume_model, double *volume_tree); void write_elem_geometry_2d_c(const char *ELEMFILE, int *filename_len); void write_geo_file_c(int *ntype, const char *GEOFILE, int *filename_len); @@ -134,11 +133,6 @@ void evaluate_ordering() evaluate_ordering_c(); } -void initialise_lung_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin) -{ - initialise_lung_volume_c(&Gdirn, &COV, &total_volume, &Rmax, &Rmin); -} - void volume_of_mesh(double *volume_model, double *volume_tree) { volume_of_mesh_c(volume_model, volume_tree); diff --git a/src/bindings/c/geometry.f90 b/src/bindings/c/geometry.f90 index 16706d58..0f81e5bd 100644 --- a/src/bindings/c/geometry.f90 +++ b/src/bindings/c/geometry.f90 @@ -306,25 +306,6 @@ subroutine evaluate_ordering_c() bind(C, name="evaluate_ordering_c") end subroutine evaluate_ordering_c -!################################################################################### -! -!>*initialise_lung_volume:* assigns a volume to terminal units appended on a tree structure -!>based on an assumption of a linear gradient in the gravitational direction with max -!> min and COV values defined. - subroutine initialise_lung_volume_c(Gdirn, COV, total_volume, Rmax, Rmin) bind(C, name="initialise_lung_volume_c") - - use geometry, only: initialise_lung_volume - use arrays, only: dp - implicit none - - ! Parameter List - integer,intent(in) :: Gdirn - real(dp),intent(in) :: COV, total_volume, Rmax, Rmin - - call initialise_lung_volume(Gdirn, COV, total_volume, Rmax, Rmin) - - end subroutine initialise_lung_volume_c - ! !################################################################################### ! diff --git a/src/bindings/c/geometry.h b/src/bindings/c/geometry.h index f4bd9c82..44780a25 100644 --- a/src/bindings/c/geometry.h +++ b/src/bindings/c/geometry.h @@ -22,7 +22,6 @@ SHO_PUBLIC void define_rad_from_geom(const char *ORDER_SYSTEM, double CONTROL_PA double START_RAD, const char *GROUP_TYPE, const char *GROUP_OPTIONS); SHO_PUBLIC void element_connectivity_1d(); SHO_PUBLIC void evaluate_ordering(); -SHO_PUBLIC void initialise_lung_volume(int Gdirn, double COV, double total_volume, double Rmax, double Rmin); SHO_PUBLIC void volume_of_mesh(double *volume_model, double *volume_tree); SHO_PUBLIC void write_elem_geometry_2d(const char *ELEMFILE); SHO_PUBLIC void write_geo_file(int ntype, const char *GEOFILE); diff --git a/src/bindings/c/ventilation.c b/src/bindings/c/ventilation.c index d37755d9..2d113075 100644 --- a/src/bindings/c/ventilation.c +++ b/src/bindings/c/ventilation.c @@ -1,13 +1,13 @@ #include "ventilation.h" -void evaluate_vent_c(int *num_breaths, double *dt); +void evaluate_vent_c(); void evaluate_uniform_flow_c(); void two_unit_test_c(); -void evaluate_vent(int num_breaths, double dt) +void evaluate_vent() { - evaluate_vent_c(&num_breaths, &dt); + evaluate_vent_c(); } void evaluate_uniform_flow() diff --git a/src/bindings/c/ventilation.f90 b/src/bindings/c/ventilation.f90 index f2e05b04..146c2def 100644 --- a/src/bindings/c/ventilation.f90 +++ b/src/bindings/c/ventilation.f90 @@ -6,16 +6,13 @@ module ventilation_c !!!################################################################################### - subroutine evaluate_vent_c(num_breaths, dt) bind(C, name="evaluate_vent_c") + subroutine evaluate_vent_c() bind(C, name="evaluate_vent_c") use arrays,only: dp use ventilation, only: evaluate_vent implicit none - integer, intent(in) :: num_breaths - real(dp), intent(in) :: dt - - call evaluate_vent(num_breaths, dt) + call evaluate_vent() end subroutine evaluate_vent_c diff --git a/src/bindings/c/ventilation.h b/src/bindings/c/ventilation.h index db7ad285..68f101c3 100644 --- a/src/bindings/c/ventilation.h +++ b/src/bindings/c/ventilation.h @@ -3,7 +3,7 @@ #include "symbol_export.h" -SHO_PUBLIC void evaluate_vent(int num_breaths, double dt); +SHO_PUBLIC void evaluate_vent(); SHO_PUBLIC void evaluate_uniform_flow(); SHO_PUBLIC void two_unit_test(); diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 19b2b25a..32e1160e 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -47,7 +47,7 @@ module geometry public make_data_grid public make_2d_vessel_from_1d public reallocate_node_elem_arrays - public initialise_lung_volume + public set_initial_volume public triangles_from_surface public volume_of_mesh public write_geo_file @@ -3004,16 +3004,14 @@ end subroutine evaluate_ordering !!!############################################################################# - subroutine initialise_lung_volume(Gdirn,COV,total_volume,Rmax,Rmin) - !*initialise_lung_volume:* assigns a volume to terminal units appended on a + subroutine set_initial_volume(Gdirn,COV,total_volume,Rmax,Rmin) + !*set_initial_volume:* assigns a volume to terminal units appended on a ! tree structure based on an assumption of a linear gradient in the ! gravitational direction with max, min, and COV values defined. - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIALISE_LUNG_VOLUME" :: INITIALISE_LUNG_VOLUME integer,intent(in) :: Gdirn real(dp),intent(in) :: COV,total_volume,Rmax,Rmin ! Local parameters - !type(lung_volumes) :: volumes ! has the default values, and is updated to use in other modules integer :: ne,np2,nunit real(dp) :: factor_adjust,max_z,min_z,random_number,range_z,& volume_estimate,volume_of_tree,Vmax,Vmin,Xi @@ -3021,15 +3019,9 @@ subroutine initialise_lung_volume(Gdirn,COV,total_volume,Rmax,Rmin) ! -------------------------------------------------------------------------- - sub_name = 'initialise_lung_volume' + sub_name = 'set_initial_volume' call enter_exit(sub_name,1) - - ! update the default parameters - lung_volumes%frc = total_volume - lung_volumes%Rmax = Rmax - lung_volumes%Rmin = Rmin - lung_volumes%COV = COV - + volume_estimate = 1.0_dp volume_of_tree = 0.0_dp @@ -3078,7 +3070,7 @@ subroutine initialise_lung_volume(Gdirn,COV,total_volume,Rmax,Rmin) call enter_exit(sub_name,2) - end subroutine initialise_lung_volume + end subroutine set_initial_volume !!!############################################################################# diff --git a/src/lib/ventilation.f90 b/src/lib/ventilation.f90 index 03e06cce..11f704ad 100644 --- a/src/lib/ventilation.f90 +++ b/src/lib/ventilation.f90 @@ -33,107 +33,142 @@ module ventilation public sum_elem_field_from_periphery real(dp),parameter,private :: gravity = 9.81e3_dp ! mm/s2 +!!! for air + real(dp),parameter,private :: gas_density = 1.146e-6_dp ! g.mm^-3 + real(dp),parameter,private :: gas_viscosity = 1.8e-5_dp ! Pa.s contains !!!############################################################################# - subroutine evaluate_vent(num_breaths, dt) + subroutine evaluate_vent !*evaluate_vent:* Sets up and solves dynamic ventilation model - integer, intent(in) :: num_breaths - real(dp), intent(in) :: dt ! Local variables - integer :: iter_step,n,ne,nunit + integer :: gdirn ! 1(x), 2(y), 3(z); upright lung (for our + ! models) is z, supine is y. + integer :: iter_step,n,ne,num_brths,num_itns,nunit real(dp) :: chestwall_restvol ! resting volume of chest wall - real(dp) :: P_muscle ! muscle (driving) pressure + real(dp) :: chest_wall_compliance ! constant compliance of chest wall + real(dp) :: constrict ! for applying uniform constriction + real(dp) :: COV ! COV of tissue compliance + real(dp) :: i_to_e_ratio ! ratio inspiration to expiration time + real(dp) :: p_mus ! muscle (driving) pressure + real(dp) :: pmus_factor_ex ! pmus_factor (_in and _ex) used to scale + real(dp) :: pmus_factor_in ! modifies driving pressures to converge + ! tidal volume and expired volume to the + ! target volume. + real(dp) :: pmus_step ! change in Ppl for driving flow (Pa) + real(dp) :: press_in ! constant pressure at entry to model (Pa) + real(dp) :: press_in_total ! dynamic pressure at entry to model (Pa) + real(dp) :: refvol ! proportion of model for 'zero stress' + real(dp) :: RMaxMean ! ratio max to mean volume + real(dp) :: RMinMean ! ratio min to mean volume real(dp) :: sum_expid ! sum of expired volume (mm^3) real(dp) :: sum_tidal ! sum of inspired volume (mm^3) real(dp) :: Texpn ! time for expiration (s) + real(dp) :: T_interval ! the total length of the breath (s) real(dp) :: Tinsp ! time for inspiration (s) real(dp) :: undef ! the zero stress volume. undef < RV + real(dp) :: volume_target ! the target tidal volume (mm^3) - real(dp) :: dP_muscle,endtime,err_est,init_vol,last_vol, & - current_vol,Pcw,P_muscle_peak,ppl_current,P_recoil,P_residual, & - P_transp,prev_flow,ptrans_frc, & - time,ttime,volume_tree,WOBe,WOBr,WOBe_insp,WOBr_insp,WOB_insp + real(dp) :: dpmus,dt,endtime,err_est,err_tol,FRC,init_vol,last_vol, & + current_vol,Pcw,ppl_current,pptrans,prev_flow,ptrans_frc, & + sum_dpmus,sum_dpmus_ei,time,totalc,Tpass,ttime,volume_tree,WOBe,WOBr, & + WOBe_insp,WOBr_insp,WOB_insp + character :: expiration_type*(10) ! active (sine wave), passive, pressure logical :: CONTINUE,converged - character(len=60) :: filename = 'ventilation.opvent' - + character(len=60) :: sub_name ! -------------------------------------------------------------------------- sub_name = 'evaluate_vent' call enter_exit(sub_name,1) - - open(10, file=filename, status='replace') !!! Initialise variables: + pmus_factor_in = 1.0_dp + pmus_factor_ex = 1.0_dp time = 0.0_dp !initialise the simulation time. n = 0 !initialise the 'breath number'. incremented at start of each breath. sum_tidal = 0.0_dp ! initialise the inspired and expired volumes sum_expid = 0.0_dp last_vol = 0.0_dp +!!! set default values for the parameters that control the breathing simulation +!!! these should be controlled by user input (showing hard-coded for now) + + call read_params_evaluate_flow(gdirn, chest_wall_compliance, & + constrict, COV, FRC, i_to_e_ratio, pmus_step, press_in,& + refvol, RMaxMean, RMinMean, T_interval, volume_target, expiration_type) + call read_params_main(num_brths, num_itns, dt, err_tol) + +!!! set dynamic pressure at entry. only changes for the 'pressure' option + press_in_total = press_in + !!! calculate key variables from the boundary conditions/problem parameters - Texpn = ventilation_values%time_breath / (1.0_dp+ventilation_values%i_to_e_ratio) - Tinsp = ventilation_values%time_breath - Texpn + Texpn = T_interval / (1.0_dp+i_to_e_ratio) + Tinsp = T_interval - Texpn !!! store initial branch lengths, radii, resistance etc. in array 'elem_field' call update_elem_field(1.0_dp) call update_resistance call volume_of_mesh(init_vol,volume_tree) - undef = lung_mechanics%refvol_ratio * (lung_volumes%FRC-volume_tree)/dble(elem_units_below(1)) +!!! distribute the initial tissue unit volumes along the gravitational axis. + call set_initial_volume(gdirn,COV,FRC*1.0e+6_dp,RMaxMean,RMinMean) + undef = refvol * (FRC*1.0e+6_dp-volume_tree)/dble(elem_units_below(1)) !!! calculate the total model volume call volume_of_mesh(init_vol,volume_tree) - current_vol = init_vol - write(*,'('' Anatomical deadspace = '',F8.3,'' ml'')') volume_tree/1.0e+3_dp ! in mL - write(*,'('' Respiratory volume = '',F8.3,'' L'')') (init_vol-volume_tree)/1.0e+6_dp !in L - write(*,'('' Total lung volume = '',F8.3,'' L'')') init_vol/1.0e+6_dp !in L + write(*,'('' Anatomical deadspace = '',F8.3,'' ml'')') & + volume_tree/1.0e+3_dp ! in mL + write(*,'('' Respiratory volume = '',F8.3,'' L'')') & + (init_vol-volume_tree)/1.0e+6_dp !in L + write(*,'('' Total lung volume = '',F8.3,'' L'')') & + init_vol/1.0e+6_dp !in L unit_field(nu_dpdt,1:num_units) = 0.0_dp !!! calculate the compliance of each tissue unit - call tissue_compliance(undef) + call tissue_compliance(chest_wall_compliance,undef) + totalc = SUM(unit_field(nu_comp,1:num_units)) !the total model compliance call update_pleural_pressure(ppl_current) !calculate new pleural pressure - P_transp=SUM(unit_field(nu_pe,1:num_units))/num_units - P_recoil = P_transp - P_residual = 0.0_dp + pptrans=SUM(unit_field(nu_pe,1:num_units))/num_units - chestwall_restvol = init_vol + lung_mechanics%chest_wall_compliance * (-ppl_current) - Pcw = (chestwall_restvol - init_vol)/lung_mechanics%chest_wall_compliance + chestwall_restvol = init_vol + chest_wall_compliance * (-ppl_current) + Pcw = (chestwall_restvol - init_vol)/chest_wall_compliance write(*,'('' Chest wall RV = '',F8.3,'' L'')') chestwall_restvol/1.0e+6_dp - call write_flow_step_results(init_vol,current_vol,ppl_current,P_transp,Pcw,P_muscle,0.0_dp,0.0_dp) + call write_flow_step_results(chest_wall_compliance,init_vol, & + current_vol,ppl_current,pptrans,Pcw,p_mus,0.0_dp,0.0_dp) continue = .true. do while (continue) n = n + 1 ! increment the breath number ttime = 0.0_dp ! each breath starts with ttime=0 - endtime = ventilation_values%time_breath * dble(n) - 0.5_dp * dt ! the end time of this breath - P_muscle = 0.0_dp + endtime = T_interval * n - 0.5_dp * dt ! the end time of this breath + p_mus = 0.0_dp ptrans_frc = SUM(unit_field(nu_pe,1:num_units))/num_units !ptrans at frc if(n.gt.1)then !write out 'end of breath' information - call write_end_of_breath(init_vol,current_vol,sum_expid,sum_tidal,WOBe_insp, & + call write_end_of_breath(init_vol,current_vol,pmus_factor_in, & + pmus_step,sum_expid,sum_tidal,volume_target,WOBe_insp, & WOBr_insp,WOB_insp) - if(abs(ventilation_values%tidal_volume).gt.1.0e-5_dp)THEN + if(abs(volume_target).gt.1.0e-5_dp)THEN ! modify driving muscle pressure by volume_target/sum_tidal - ! this increases P_muscle for volume_target>sum_tidal, and - ! decreases P_muscle for volume_targetsum_tidal, and + ! decreases p_mus for volume_target mm^3/Pa) + + open(fh, file='Parameters/params_evaluate_flow.txt') + + ! ios is negative if an end of record condition is encountered or if + ! an endfile condition was detected. It is positive if an error was + ! detected. ios is zero otherwise. + + do while (ios == 0) + read(fh, '(A)', iostat=ios) buffer + if (ios == 0) then + line = line + 1 + + ! Find the first instance of whitespace. Split label and data. + pos = scan(buffer, ' ') + label = buffer(1:pos) + buffer = buffer(pos+1:) + + select case (label) + case ('FRC') + read(buffer, *, iostat=ios) FRC + print *, 'Read FRC: ', FRC + case ('constrict') + read(buffer, *, iostat=ios) constrict + print *, 'Read constrict: ', constrict + case ('T_interval') + read(buffer, *, iostat=ios) T_interval + print *, 'Read T_interval: ', T_interval + case ('Gdirn') + read(buffer, *, iostat=ios) gdirn + print *, 'Read Gdirn: ', gdirn + case ('press_in') + read(buffer, *, iostat=ios) press_in + print *, 'Read press_in: ', press_in + case ('COV') + read(buffer, *, iostat=ios) COV + print *, 'Read COV: ', COV + case ('RMaxMean') + read(buffer, *, iostat=ios) RMaxMean + print *, 'Read RMaxMean: ', RMaxMean + case ('RMinMean') + read(buffer, *, iostat=ios) RMinMean + print *, 'Read RMinMean: ', RMinMean + case ('i_to_e_ratio') + read(buffer, *, iostat=ios) i_to_e_ratio + print *, 'Read i_to_e_ratio: ', i_to_e_ratio + case ('refvol') + read(buffer, *, iostat=ios) refvol + print *, 'Read refvol: ', refvol + case ('volume_target') + read(buffer, *, iostat=ios) volume_target + print *, 'Read volume_target: ', volume_target + case ('pmus_step') + read(buffer, *, iostat=ios) pmus_step + print *, 'Read pmus_step_coeff: ', pmus_step + case ('expiration_type') + read(buffer, *, iostat=ios) expiration_type + print *, 'Read expiration_type: ', expiration_type + case ('chest_wall_compliance') + read(buffer, *, iostat=ios) chest_wall_compliance + print *, 'Read chest_wall_compliance: ', chest_wall_compliance + case default + print *, 'Skipping invalid label at line', line + end select + end if + end do + + close(fh) + call enter_exit(sub_name,2) + + end subroutine read_params_evaluate_flow + !!!############################################################################# subroutine two_unit_test @@ -898,11 +1109,11 @@ end subroutine two_unit_test !!!############################################################################# - subroutine write_end_of_breath(init_vol,current_vol, & - sum_expid,sum_tidal,WOBe_insp,WOBr_insp,WOB_insp) + subroutine write_end_of_breath(init_vol,current_vol,pmus_factor_in, & + pmus_step,sum_expid,sum_tidal,volume_target,WOBe_insp,WOBr_insp,WOB_insp) - real(dp),intent(in) :: init_vol,current_vol, & - sum_expid,sum_tidal,WOBe_insp,WOBr_insp,WOB_insp + real(dp),intent(in) :: init_vol,current_vol,pmus_factor_in,pmus_step, & + sum_expid,sum_tidal,volume_target,WOBe_insp,WOBr_insp,WOB_insp ! Local variables character(len=60) :: sub_name @@ -916,11 +1127,11 @@ subroutine write_end_of_breath(init_vol,current_vol, & write(*,'('' End of breath, expired = '',F10.2,'' L'')') & sum_expid/1.0e+6_dp write(*,'('' Peak muscle pressure = '',F10.2,'' cmH2O'')') & - ventilation_values%P_muscle_estimate*ventilation_values%factor_P_muscle_insp/98.0665_dp + pmus_step*pmus_factor_in/98.0665_dp write(*,'('' Drift in FRC from start = '',F10.2,'' %'')') & - 100.0_dp*(current_vol-init_vol)/init_vol + 100*(current_vol-init_vol)/init_vol write(*,'('' Difference from target Vt = '',F8.2,'' %'')') & - 100.0_dp*(ventilation_values%tidal_volume-sum_tidal)/ventilation_values%tidal_volume + 100*(volume_target-sum_tidal)/volume_target write(*,'('' Total Work of Breathing ='',F7.3,''J/min'')')WOB_insp write(*,'('' elastic WOB ='',F7.3,''J/min'')')WOBe_insp write(*,'('' resistive WOB='',F7.3,''J/min'')')WOBr_insp @@ -931,11 +1142,11 @@ end subroutine write_end_of_breath !!!############################################################################# - subroutine write_flow_step_results(init_vol, & - current_vol,ppl_current,P_transp,Pcw,P_muscle,time,ttime) + subroutine write_flow_step_results(chest_wall_compliance,init_vol, & + current_vol,ppl_current,pptrans,Pcw,p_mus,time,ttime) - real(dp),intent(in) :: init_vol,current_vol, & - ppl_current,P_transp,Pcw,P_muscle,time,ttime + real(dp),intent(in) :: chest_wall_compliance,init_vol,current_vol, & + ppl_current,pptrans,Pcw,p_mus,time,ttime ! Local variables real(dp) :: totalC,Precoil character(len=60) :: sub_name @@ -947,7 +1158,7 @@ subroutine write_flow_step_results(init_vol, & !the total model compliance totalC = 1.0_dp/(1.0_dp/sum(unit_field(nu_comp,1:num_units))+ & - 1.0_dp/lung_mechanics%chest_wall_compliance) + 1.0_dp/chest_wall_compliance) Precoil = sum(unit_field(nu_pe,1:num_units))/num_units if(abs(time).lt.zero_tol)then @@ -969,16 +1180,6 @@ subroutine write_flow_step_results(init_vol, & 0.0_dp, & !Pmuscle (cmH2O) Pcw/98.0665_dp, & !Pchest_wall (cmH2O) (-Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) - write(10,'(F7.3,2(F8.1),8(F8.2))') & - 0.0_dp,0.0_dp,0.0_dp, & !time, flow, tidal - elem_field(ne_t_resist,1)*1.0e+6_dp/98.0665_dp, & !res (cmH2O/L.s) - totalC*98.0665_dp/1.0e+6_dp, & !total model compliance - ppl_current/98.0665_dp, & !Ppl (cmH2O) - -ppl_current/98.0665_dp, & !mean Ptp (cmH2O) - init_vol/1.0e+6_dp, & !total model volume (L) - 0.0_dp, & !Pmuscle (cmH2O) - Pcw/98.0665_dp, & !Pchest_wall (cmH2O) - (-Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) else write(*,'(F7.3,2(F8.1),8(F8.2))') & time, & !time through breath (s) @@ -987,23 +1188,11 @@ subroutine write_flow_step_results(init_vol, & elem_field(ne_t_resist,1)*1.0e+6_dp/98.0665_dp, & !res (cmH2O/L.s) totalC*98.0665_dp/1.0e+6_dp, & !total model compliance ppl_current/98.0665_dp, & !Ppl (cmH2O) - P_transp/98.0665_dp, & !mean Ptp (cmH2O) - current_vol/1.0e+6_dp, & !total model volume (L) - P_muscle/98.0665_dp, & !Pmuscle (cmH2O) - -Pcw/98.0665_dp, & !Pchest_wall (cmH2O) - (P_muscle+Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) - write(10,'(F7.3,2(F8.1),8(F8.2))') & - time, & !time through breath (s) - elem_field(ne_Vdot,1)/1.0e+3_dp, & !flow at the inlet (mL/s) - (current_vol - init_vol)/1.0e+3_dp, & !current tidal volume (mL) - elem_field(ne_t_resist,1)*1.0e+6_dp/98.0665_dp, & !res (cmH2O/L.s) - totalC*98.0665_dp/1.0e+6_dp, & !total model compliance - ppl_current/98.0665_dp, & !Ppl (cmH2O) - P_transp/98.0665_dp, & !mean Ptp (cmH2O) + pptrans/98.0665_dp, & !mean Ptp (cmH2O) current_vol/1.0e+6_dp, & !total model volume (L) - P_muscle/98.0665_dp, & !Pmuscle (cmH2O) + p_mus/98.0665_dp, & !Pmuscle (cmH2O) -Pcw/98.0665_dp, & !Pchest_wall (cmH2O) - (P_muscle+Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) + (p_mus+Pcw)/98.0665_dp !Pmuscle - Pchest_wall (cmH2O) endif @@ -1013,21 +1202,21 @@ end subroutine write_flow_step_results !!!############################################################################# - function ventilation_continue(n,num_breaths,sum_tidal) + function ventilation_continue(n,num_brths,sum_tidal,volume_target) - integer,intent(in) :: n,num_breaths - real(dp),intent(in) :: sum_tidal + integer,intent(in) :: n,num_brths + real(dp),intent(in) :: sum_tidal,volume_target ! Local variables logical :: ventilation_continue ! -------------------------------------------------------------------------- ventilation_continue = .true. - if(n.ge.num_breaths)then + if(n.ge.num_brths)then ventilation_continue = .false. - elseif(abs(ventilation_values%tidal_volume).gt.1.0e-3_dp)then - if(abs(100.0_dp*(ventilation_values%tidal_volume-sum_tidal) & - /ventilation_values%tidal_volume).gt.0.1_dp.or.(n.lt.2))then + elseif(abs(volume_target).gt.1.0e-3_dp)then + if(abs(100.0_dp*(volume_target-sum_tidal) & + /volume_target).gt.0.1_dp.or.(n.lt.2))then ventilation_continue = .true. else ventilation_continue = .false. From 68e8888a6d89b58c28874d06bc5f4cace27a4edc Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 13:36:34 +1200 Subject: [PATCH 23/25] removing changes to capillaryflow, wave_transmission, pressure_resistance_flow --- src/lib/capillaryflow.f90 | 25 +- src/lib/pressure_resistance_flow.f90 | 389 +++------------------------ src/lib/wave_transmission.f90 | 9 +- 3 files changed, 55 insertions(+), 368 deletions(-) diff --git a/src/lib/capillaryflow.f90 b/src/lib/capillaryflow.f90 index dbc28d19..9bf12f75 100644 --- a/src/lib/capillaryflow.f90 +++ b/src/lib/capillaryflow.f90 @@ -922,6 +922,7 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& type(elasticity_param) :: elast_param type(capillary_bf_parameters) :: cap_param + type(fluid_properties) :: fp integer :: ngen real(dp) :: alpha_c,area_scale,length_scale real(dp) :: radupdate,P_exta,P_extv,R_art1,R_ven1,R_art2,R_ven2,Q01_mthrees,Pin,Pout @@ -1156,11 +1157,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) !!!ARC TO FIX alpha_a is in m/Pa, need in 1/Pa (just read in from main model?) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*(elast_param%elasticity_parameters(1))))*sqrt(1-f10)!alpha in the sense of this model is 1/Pa so has to be dovided by radius - tube_admit(gen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) + wavespeed=sqrt(1.0_dp/(2*fp%blood_density*(elast_param%elasticity_parameters(1))))*sqrt(1-f10)!alpha in the sense of this model is 1/Pa so has to be dovided by radius + tube_admit(gen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) prop_const(gen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed) enddo !!... FIRST HALF OF VENULE @@ -1184,11 +1185,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& Pout=Pout+R_ven1*Q01_mthrees do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s - tube_admit(gen+2*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10)!mm3/Pa.s + wavespeed=sqrt(1.0_dp/(2*fp%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s + tube_admit(gen+2*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10)!mm3/Pa.s prop_const(gen+2*ngen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed)!1/mm enddo @@ -1227,11 +1228,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) - tube_admit(gen+ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) + wavespeed=sqrt(1.0_dp/(2*fp%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) + tube_admit(gen+ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) prop_const(gen+ngen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed) enddo @@ -1250,11 +1251,11 @@ subroutine cap_flow_admit(ne,admit,eff_admit_downstream,Lin,Lout,P1,P2,& Pout=Pout-R_ven2*Q01_mthrees do nf=1,no_freq !radius needs to be multipled by 1000 to go to mm (units of rest of model) omega=nf*2*PI*harmonic_scale - wolmer=(radupdate*1000.0_dp)*sqrt(omega*fluid_properties%blood_density/mu_app(gen)) + wolmer=(radupdate*1000.0_dp)*sqrt(omega*fp%blood_density/mu_app(gen)) call bessel_complex(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp),bessel0,bessel1) f10=2*bessel1/(wolmer*cmplx(0.0_dp,1.0_dp,8)**(3.0_dp/2.0_dp)*bessel0) - wavespeed=sqrt(1.0_dp/(2*fluid_properties%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s - tube_admit(gen+3*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fluid_properties%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) + wavespeed=sqrt(1.0_dp/(2*fp%blood_density*elast_param%elasticity_parameters(1)))*sqrt(1-f10) !mm/s + tube_admit(gen+3*ngen,nf)=PI*(radupdate*1000.0_dp)**2/(fp%blood_density*wavespeed/sqrt(1-f10))*sqrt(1-f10) prop_const(gen+3*ngen,nf)=cmplx(0.0_dp,1.0_dp,8)*omega/(wavespeed) !1/mm enddo enddo diff --git a/src/lib/pressure_resistance_flow.f90 b/src/lib/pressure_resistance_flow.f90 index ffa3d9a1..be845678 100644 --- a/src/lib/pressure_resistance_flow.f90 +++ b/src/lib/pressure_resistance_flow.f90 @@ -26,7 +26,7 @@ module pressure_resistance_flow !Interfaces private - public evaluate_prq,calculate_ppl,update_prq + public evaluate_prq,calculate_ppl contains !################################################################################### ! @@ -35,21 +35,21 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !local variables integer :: mesh_dof,depvar_types - !integer, allocatable :: mesh_from_depvar(:,:,:) - !integer, allocatable :: depvar_at_node(:,:,:) - !integer, allocatable :: depvar_at_elem(:,:,:) + integer, allocatable :: mesh_from_depvar(:,:,:) + integer, allocatable :: depvar_at_node(:,:,:) + integer, allocatable :: depvar_at_elem(:,:,:) integer, dimension(0:2,2) :: depvar_totals - !integer, allocatable :: SparseCol(:) - !integer, allocatable :: SparseRow(:) - !integer, allocatable :: update_resistance_entries(:) - !real(dp), allocatable :: SparseVal(:) - !real(dp), allocatable :: RHS(:) + integer, allocatable :: SparseCol(:) + integer, allocatable :: SparseRow(:) + integer, allocatable :: update_resistance_entries(:) + real(dp), allocatable :: SparseVal(:) + real(dp), allocatable :: RHS(:) integer :: num_vars,NonZeros,MatrixSize integer :: AllocateStatus - !real(dp), allocatable :: prq_solution(:,:),solver_solution(:) + real(dp), allocatable :: prq_solution(:,:),solver_solution(:) real(dp) :: viscosity,density,inlet_bc,outlet_bc,inletbc,outletbc,grav_vect(3),gamma,total_resistance,ERR - !logical, allocatable :: FIX(:) + logical, allocatable :: FIX(:) logical :: ADD=.FALSE.,CONVERGED=.FALSE. character(len=60) :: sub_name,mesh_type,vessel_type,mechanics_type,bc_type integer :: grav_dirn,no,depvar,KOUNT,nz,ne,SOLVER_FLAG,ne0,ne1,nj @@ -135,8 +135,8 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !viscosity: fluid viscosity !density:fluid density !gamma:Pedley correction factor -!density=0.10500e-02_dp !kg/cm3 -!viscosity=0.33600e-02_dp !Pa.s +density=0.10500e-02_dp !kg/cm3 +viscosity=0.33600e-02_dp !Pa.s gamma = 0.327_dp !=1.85/(4*sqrt(2)) !! Allocate memory to depvar arrays @@ -162,22 +162,22 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !! Define boundary conditions !first call to define inlet boundary conditions - call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& + call boundary_conditions(ADD,FIX,bc_type,grav_vect,density,inletbc,outletbc,& depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) !second call if simple tree need to define pressure bcs at all terminal branches if(mesh_type.eq.'simple_tree')then ADD=.TRUE. - call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& + call boundary_conditions(ADD,FIX,bc_type,grav_vect,density,inletbc,outletbc,& depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) elseif(mesh_type.eq.'full_plus_ladder')then ADD=.TRUE. - call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& + call boundary_conditions(ADD,FIX,bc_type,grav_vect,density,inletbc,outletbc,& depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) endif KOUNT=0 !! Calculate resistance of each element - call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) + call calculate_resistance(viscosity,KOUNT) !! Calculate sparsity structure for solution matrices !Determine size of and allocate solution vectors/matrices @@ -196,7 +196,7 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle if (AllocateStatus /= 0) STOP "*** Not enough memory for solver_solution array ***" update_resistance_entries = 0 !calculate the sparsity structure - call calc_sparse_1dtree(bc_type,fluid_properties%blood_density,FIX,grav_vect,mesh_dof,depvar_at_elem, & + call calc_sparse_1dtree(bc_type,density,FIX,grav_vect,mesh_dof,depvar_at_elem, & depvar_at_node,NonZeros,MatrixSize,SparseCol,SparseRow,SparseVal,RHS, & prq_solution,update_resistance_entries,update_flow_nzz_row) !!! --ITERATIVE LOOP-- @@ -242,9 +242,9 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle !SparseVal(nz)=-elem_field(ne_resist,ne) !Just updating resistance endif endif!first or subsequent iteration - !! ----CALL SOLVER---- +!! ----CALL SOLVER---- call pmgmres_ilu_cr(MatrixSize, NonZeros, SparseRow, SparseCol, SparseVal, & - solver_solution, RHS, 500, 500,1.d-5,1.d-4,SOLVER_FLAG) + solver_solution, RHS, 500, 500,1.d-5,1.d-4,SOLVER_FLAG) if(SOLVER_FLAG == 0)then print *, 'Warning: pmgmres has reached max iterations. Solution may not be valid if this warning persists' elseif(SOLVER_FLAG ==2)then @@ -282,11 +282,11 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle else !Update vessel radii based on predicted pressures and then update resistance through tree call calc_press_area(grav_vect,KOUNT,depvar_at_node,prq_solution,& - mesh_dof,vessel_type,elasticity_parameters,mechanics_parameters) - call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) + mesh_dof,vessel_type,elasticity_parameters,mechanics_parameters) + call calculate_resistance(viscosity,KOUNT) !Put the ladder stuff here --> See solve11.f - if(mesh_type.eq.'full_plus_ladder')then + if(mesh_type.eq.'full_plus_ladder')then do ne=1,num_elems if(elem_field(ne_group,ne).eq.1.0_dp)then!(elem_field(ne_group,ne)-1.0_dp).lt.TOLERANCE)then ne0=elem_cnct(-1,1,ne)!upstream element number @@ -309,17 +309,18 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle endif enddo endif + ERR=ERR/MatrixSize !sum of error divided by no of unknown depvar if(ERR.LE.1.d-6.AND.(KOUNT.NE.1))then CONVERGED=.TRUE. - write(*,'('' Convergence achieved after'',i4,'' iterations, error ='',e10.3)') KOUNT,ERR + print *,"Convergence achieved after",KOUNT,"iterations",ERR else !if error not converged if(ERR.GE.MIN_ERR) then N_MIN_ERR=N_MIN_ERR+1 else MIN_ERR=ERR endif - write(*,'('' Not converged, error ='',e10.3)') ERR + print *,"Not converged, error =",ERR endif !ERR not converged endif!vessel type enddo !notconverged @@ -356,25 +357,18 @@ subroutine evaluate_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inle close(20) endif - !deallocate (mesh_from_depvar, STAT = AllocateStatus) - !deallocate (depvar_at_elem, STAT = AllocateStatus) - !deallocate (depvar_at_node, STAT = AllocateStatus) - !deallocate (prq_solution, STAT = AllocateStatus) - !deallocate (FIX, STAT = AllocateStatus) - !deallocate (solver_solution, STAT = AllocateStatus) - !deallocate (SparseCol, STAT = AllocateStatus) - !deallocate (SparseVal, STAT = AllocateStatus) - !deallocate (SparseRow, STAT = AllocateStatus) - !deallocate (RHS, STAT = AllocateStatus) - !deallocate (update_resistance_entries, STAT=AllocateStatus) - - write(*,'('' Cardiac output ='',f8.3,'' L/min for PAP ='',f8.3,'' mmHg and LAP ='',f8.3,'' mmHg'')') & - elem_field(ne_Qdot,1)/1.0e6_dp*60.0_dp, inletbc / 133.322_dp, outletbc / 133.322_dp - + deallocate (mesh_from_depvar, STAT = AllocateStatus) + deallocate (depvar_at_elem, STAT = AllocateStatus) + deallocate (depvar_at_node, STAT = AllocateStatus) + deallocate (prq_solution, STAT = AllocateStatus) + deallocate (FIX, STAT = AllocateStatus) + deallocate (solver_solution, STAT = AllocateStatus) + deallocate (SparseCol, STAT = AllocateStatus) + deallocate (SparseVal, STAT = AllocateStatus) + deallocate (SparseRow, STAT = AllocateStatus) + deallocate (RHS, STAT = AllocateStatus) + deallocate (update_resistance_entries, STAT=AllocateStatus) call enter_exit(sub_name,2) - - call update_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inlet_bc,outlet_bc) - end subroutine evaluate_prq ! !################################################################################### @@ -1086,315 +1080,6 @@ subroutine calculate_ppl(np,grav_vect,mechanics_parameters,Ppl) call enter_exit(sub_name,2) end subroutine calculate_ppl -! -!################################################################## -! - subroutine update_prq(mesh_type,vessel_type,grav_dirn,grav_factor,bc_type,inlet_bc,outlet_bc) - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_UPDATE_PRQ" :: UPDATE_PRQ - - !local variables - integer :: mesh_dof,depvar_types - !integer, allocatable :: mesh_from_depvar(:,:,:) - !integer, allocatable :: depvar_at_node(:,:,:) - !integer, allocatable :: depvar_at_elem(:,:,:) - integer, dimension(0:2,2) :: depvar_totals - !integer, allocatable :: SparseCol(:) - !integer, allocatable :: SparseRow(:) - !integer, allocatable :: update_resistance_entries(:) - !real(dp), allocatable :: SparseVal(:) - !real(dp), allocatable :: RHS(:) - integer :: num_vars,NonZeros,MatrixSize - integer :: AllocateStatus - - !real(dp), allocatable :: prq_solution(:,:),solver_solution(:) - real(dp) :: viscosity,density,inlet_bc,outlet_bc,inletbc,outletbc,grav_vect(3),gamma,total_resistance,ERR - !logical, allocatable :: FIX(:) - logical :: ADD=.FALSE.,CONVERGED=.FALSE. - character(len=60) :: sub_name,mesh_type,vessel_type,mechanics_type,bc_type - integer :: grav_dirn,no,depvar,KOUNT,nz,ne,SOLVER_FLAG,ne0,ne1,nj - real(dp) :: MIN_ERR,N_MIN_ERR,elasticity_parameters(3),mechanics_parameters(2),grav_factor,P1 - real(dp) :: P2,Q01,Rin,Rout,x_cap,y_cap,z_cap,Ppl,LPM_R,Lin,Lout - integer :: update_flow_nzz_row - - call enter_exit(sub_name,1) - - !!---------DESCRIPTION OF MODEL Types ----------- - !mesh_type: can be simple_tree, full_plus_ladder, full_sheet, full_tube The first can be airways, arteries, veins but no special features at the terminal level, the last one has arteries and veins connected by capillary units of some type (lung ladder acinus, lung sheet capillary bed, capillaries are just tubes represented by an element) - - !vessel_type: - !rigid, no elasticity, no parameters required - !elastic_g0_beta, R=R0*((Ptm/G0)+1.d0)^(1.d0/elasticity_parameters(2)),with an optional maximum pressure beyond which the vessel radius is constant three parameters, g0, elasticity_parameters(2), elasticity_parameters(3) - !elastic alpha, R=R0*(alpha*Ptm+1.d0), up to a limit elasticity_parameters(3) two parameters alpha, elasticity_parameters(3) - !elastic_hooke, two parameters E and h,R=R0+3.0_dp*R0**2*Ptm/(4.0_dp*E*h*R0) - - !mechanics type: - !linear two parmeters, transpulmonary pressure (average) and pleural density (gradient) - !mechanics, two parameters, pressure and stretch fields - - !bc_type: - !pressure (at inlet and outlets) - !flow (flow at inlet pressure at outlet). - - - mechanics_type='linear' - - if (vessel_type.eq.'rigid') then - elasticity_parameters=0.0_dp - elseif (vessel_type.eq.'elastic_g0_beta') then - elasticity_parameters(1)=6.67e3_dp!G0 (Pa) - elasticity_parameters(2)=1.0_dp!elasticity_parameters(2) - elasticity_parameters(3)=32.0_dp*98.07_dp !elasticity_parameters(3) (Pa) - elseif (vessel_type.eq.'elastic_alpha') then - elasticity_parameters(1)=1.503e-4_dp!alpha (1/Pa) - elasticity_parameters(2)=32.0_dp*98.07_dp !elasticity_parameters(3) (Pa) - elasticity_parameters(3)=0.0_dp !Not used - elseif (vessel_type.eq.'elastic_hooke') then - elasticity_parameters(1)=1.5e6_dp !Pa - elasticity_parameters(2)=0.1_dp!this is a fraction of the radius so is unitless - elasticity_parameters(3)=0.0_dp !Not used - else - print *, 'WARNING: Your chosen vessel type does not seem to be implemented assuming rigid' - vessel_type='rigid' - elasticity_parameters=0.0_dp - endif - - if (mechanics_type.eq.'linear') then - mechanics_parameters(1)=5.0_dp*98.07_dp !average pleural pressure (Pa) - mechanics_parameters(2)=0.25_dp*0.1e-2_dp !pleural density, defines gradient in pleural pressure - else - print *, 'ERROR: Only linear mechanics models have been implemented to date,assuming default parameters' - call exit(0) - endif - - grav_vect=0.d0 - if (grav_dirn.eq.1) then - grav_vect(1)=1.0_dp - elseif (grav_dirn.eq.2) then - grav_vect(2)=1.0_dp - elseif (grav_dirn.eq.3) then - grav_vect(3)=1.0_dp - else - print *, "ERROR: Posture not recognised (currently only x=1,y=2,z=3))" - call exit(0) - endif - grav_vect=grav_vect*grav_factor - - if(bc_type.eq.'pressure')then - inletbc=inlet_bc - outletbc=outlet_bc - elseif(bc_type.eq.'flow')then - inletbc=inlet_bc - outletbc=outlet_bc - elseif((bc_type.NE.'pressure').AND.(bc_type.NE.'flow'))then - print *,"unsupported bc_type",bc_type - call exit(1) - endif - - !!---------PHYSICAL PARAMETERS----------- - !viscosity: fluid viscosity - !density:fluid density - !gamma:Pedley correction factor - !density=0.10500e-02_dp !kg/cm3 - !viscosity=0.33600e-02_dp !Pa.s - gamma = 0.327_dp !=1.85/(4*sqrt(2)) - - mesh_dof=num_elems+num_nodes - depvar_types=2 !pressure/flow - - !! Setting up mappings between nodes, elements and solution depvar - call calc_depvar_maps(mesh_from_depvar,depvar_at_elem,& - depvar_totals,depvar_at_node,mesh_dof,num_vars) - -!! Define boundary conditions - !first call to define inlet boundary conditions - call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& - depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) - !second call if simple tree need to define pressure bcs at all terminal branches - if(mesh_type.eq.'simple_tree')then - ADD=.TRUE. - call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& - depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) - elseif(mesh_type.eq.'full_plus_ladder')then - ADD=.TRUE. - call boundary_conditions(ADD,FIX,bc_type,grav_vect,fluid_properties%blood_density,inletbc,outletbc,& - depvar_at_node,depvar_at_elem,prq_solution,mesh_dof,mesh_type) - endif - - KOUNT=0 -!! Calculate resistance of each element - call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) - -!! Calculate sparsity structure for solution matrices - !Determine size of and allocate solution vectors/matrices - call calc_sparse_size(mesh_dof,depvar_at_elem,depvar_at_node,FIX,NonZeros,MatrixSize) - - !calculate the sparsity structure - call calc_sparse_1dtree(bc_type,fluid_properties%blood_density,FIX,grav_vect,mesh_dof,depvar_at_elem, & - depvar_at_node,NonZeros,MatrixSize,SparseCol,SparseRow,SparseVal,RHS, & - prq_solution,update_resistance_entries,update_flow_nzz_row) -!!! --ITERATIVE LOOP-- - MIN_ERR=1.d10 - N_MIN_ERR=0 - do while(.NOT.CONVERGED) - KOUNT=KOUNT+1 - print*, 'Outer loop iterations:',KOUNT -!!! Initialise solution vector based on bcs and rigid vessel resistance - if(KOUNT.eq.1)then!set up boundary conditions - if(bc_type.eq.'pressure')then - if(mesh_type.eq.'full_plus_ladder')then - total_resistance=1000.0_dp - else - call tree_resistance(total_resistance) - endif - call initialise_solution(inletbc,outletbc,(inletbc-outletbc)/total_resistance, & - mesh_dof,prq_solution,depvar_at_node,depvar_at_elem,FIX) - !move initialisation to solver solution (skipping BCs). - no=0 - do depvar=1,mesh_dof !loop over mesh dofs - if(.NOT.FIX(depvar))then - no=no+1 - solver_solution(no)=prq_solution(depvar,1) - endif - enddo !mesh_dof - else!flow BCs to be implemented - endif - else!Need to update just the resistance values in the solution matrix - do ne=1,num_elems !update for all ne - if(update_resistance_entries(ne).gt.0)then - nz=update_resistance_entries(ne) - SparseVal(nz)=-elem_field(ne_resist,ne) !Just updating resistance - endif - enddo - if(bc_type.eq.'flow')then !update RHS to account for element resistance - do ne=1,num_elems - depvar = depvar_at_elem(1,1,ne) - if(FIX(depvar))then - RHS(update_flow_nzz_row) = prq_solution(depvar,1)*elem_field(ne_resist,ne) - endif - enddo - !SparseVal(nz)=-elem_field(ne_resist,ne) !Just updating resistance - endif - endif!first or subsequent iteration - !! ----CALL SOLVER---- - call pmgmres_ilu_cr(MatrixSize, NonZeros, SparseRow, SparseCol, SparseVal, & - solver_solution, RHS, 500, 500,1.d-5,1.d-4,SOLVER_FLAG) - if(SOLVER_FLAG == 0)then - print *, 'Warning: pmgmres has reached max iterations. Solution may not be valid if this warning persists' - elseif(SOLVER_FLAG ==2)then - print *, 'ERROR: pmgmres has failed to converge' - deallocate (mesh_from_depvar, STAT = AllocateStatus) - deallocate (depvar_at_elem, STAT = AllocateStatus) - deallocate (depvar_at_node, STAT = AllocateStatus) - deallocate (prq_solution, STAT = AllocateStatus) - deallocate (FIX, STAT = AllocateStatus) - deallocate (solver_solution, STAT = AllocateStatus) - deallocate (SparseCol, STAT = AllocateStatus) - deallocate (SparseVal, STAT = AllocateStatus) - deallocate (SparseRow, STAT = AllocateStatus) - deallocate (RHS, STAT = AllocateStatus) - deallocate (update_resistance_entries, STAT=AllocateStatus) - exit - endif -!!--TRANSFER SOLVER SOLUTIONS TO FULL SOLUTIONS - ERR=0.0_dp - no=0 - do depvar=1,mesh_dof - if(.NOT.FIX(depvar)) THEN - no=no+1 - prq_solution(depvar,2)=prq_solution(depvar,1) !temp storage of previous solution - prq_solution(depvar,1)=solver_solution(no) !new pressure & flow solutions - if(DABS(prq_solution(depvar,1)).GT.0.d-6)THEN - ERR=ERR+(prq_solution(depvar,2)-prq_solution(depvar,1))**2.d0/prq_solution(depvar,1)**2 - endif - endif - enddo !no2 -!rigid vessels no need to update - tag as converged and exit - if(vessel_type.eq.'rigid')then - ERR=0.0_dp - CONVERGED=.TRUE. - else -!Update vessel radii based on predicted pressures and then update resistance through tree - call calc_press_area(grav_vect,KOUNT,depvar_at_node,prq_solution,& - mesh_dof,vessel_type,elasticity_parameters,mechanics_parameters) - call calculate_resistance(fluid_properties%blood_viscosity,KOUNT) - -!Put the ladder stuff here --> See solve11.f - if(mesh_type.eq.'full_plus_ladder')then - do ne=1,num_elems - if(elem_field(ne_group,ne).eq.1.0_dp)then!(elem_field(ne_group,ne)-1.0_dp).lt.TOLERANCE)then - ne0=elem_cnct(-1,1,ne)!upstream element number - ne1=elem_cnct(1,1,ne) - P1=prq_solution(depvar_at_node(elem_nodes(2,ne0),0,1),1) !pressure at start node of capillary element - P2=prq_solution(depvar_at_node(elem_nodes(1,ne1),0,1),1)!pressure at end node of capillary element - Q01=prq_solution(depvar_at_elem(1,1,ne0),1) !flow in element upstream of capillary element !mm^3/s - Rin=elem_field(ne_radius_out0,ne0)!radius of upstream element - Rout=elem_field(ne_radius_out0,ne1) !radius of downstream element - x_cap=node_xyz(1,elem_nodes(1,ne)) - y_cap=node_xyz(2,elem_nodes(1,ne)) - z_cap=node_xyz(3,elem_nodes(1,ne)) - call calculate_ppl(elem_nodes(1,ne),grav_vect,mechanics_parameters,Ppl) - Lin=elem_field(ne_length,ne0) - Lout=elem_field(ne_length,ne1) - call cap_flow_ladder(ne,LPM_R,Lin,Lout,P1,P2,& - Ppl,Q01,Rin,Rout,x_cap,y_cap,z_cap,& - .FALSE.) - elem_field(ne_resist,ne)=LPM_R - endif - enddo - endif - ERR=ERR/MatrixSize !sum of error divided by no of unknown depvar - if(ERR.LE.1.d-6.AND.(KOUNT.NE.1))then - CONVERGED=.TRUE. - write(*,'('' Convergence achieved after'',i4,'' iterations, error ='',e10.3)') KOUNT,ERR - else !if error not converged - if(ERR.GE.MIN_ERR) then - N_MIN_ERR=N_MIN_ERR+1 - else - MIN_ERR=ERR - endif - write(*,'('' Not converged, error ='',e10.3)') ERR - endif !ERR not converged - endif!vessel type - enddo !notconverged - -!need to write solution to element/nodal fields for export - call map_solution_to_mesh(prq_solution,depvar_at_elem,depvar_at_node,mesh_dof) - !NEED TO UPDATE TERMINAL SOLUTION HERE. LOOP THO' UNITS AND TAKE FLOW AND PRESSURE AT TERMINALS - call map_flow_to_terminals - !EXPORT LADDER SOLUTION - if(mesh_type.eq.'full_plus_ladder')then - open(10, file='micro_flow_ladder.out', status='replace') - open(20, file='micro_flow_unit.out', status='replace') - do ne=1,num_elems - if(elem_field(ne_group,ne).eq.1.0_dp)then!(elem_field(ne_group,ne)-1.0_dp).lt.TOLERANCE)then - ne0=elem_cnct(-1,1,ne)!upstream element number - ne1=elem_cnct(1,1,ne) - P1=prq_solution(depvar_at_node(elem_nodes(2,ne0),0,1),1) !pressure at start node of capillary element - P2=prq_solution(depvar_at_node(elem_nodes(1,ne1),0,1),1)!pressure at end node of capillary element - Q01=prq_solution(depvar_at_elem(1,1,ne0),1) !flow in element upstream of capillary element !mm^3/s - Rin=elem_field(ne_radius_out0,ne0)!radius of upstream element - Rout=elem_field(ne_radius_out0,ne1) !radius of downstream element - x_cap=node_xyz(1,elem_nodes(1,ne)) - y_cap=node_xyz(2,elem_nodes(1,ne)) - z_cap=node_xyz(3,elem_nodes(1,ne)) - call calculate_ppl(elem_nodes(1,ne),grav_vect,mechanics_parameters,Ppl) - Lin=elem_field(ne_length,ne0) - Lout=elem_field(ne_length,ne1) - call cap_flow_ladder(ne,LPM_R,Lin,Lout,P1,P2,& - Ppl,Q01,Rin,Rout,x_cap,y_cap,z_cap,& - .TRUE.) - endif - enddo - close(10) - close(20) - endif - - write(*,'('' Cardiac output ='',f8.3,'' L/min for PAP ='',f8.3,'' mmHg and LAP ='',f8.3,'' mmHg'')') & - elem_field(ne_Qdot,1)/1.0e6_dp*60.0_dp, inletbc / 133.322_dp, outletbc / 133.322_dp - - call enter_exit(sub_name,2) - - end subroutine update_prq ! !################################################################## ! diff --git a/src/lib/wave_transmission.f90 b/src/lib/wave_transmission.f90 index 1bed6a1b..0fe9651d 100644 --- a/src/lib/wave_transmission.f90 +++ b/src/lib/wave_transmission.f90 @@ -51,6 +51,7 @@ subroutine evaluate_wave_transmission(grav_dirn,grav_factor,& integer, intent(in) :: cap_model type(all_admit_param) :: admit_param + type(fluid_properties) :: fluid type(elasticity_param) :: elast_param character(len=60) :: mesh_type @@ -92,11 +93,11 @@ subroutine evaluate_wave_transmission(grav_dirn,grav_factor,& endif !viscosity and density of fluid if(model_definition(2).eq.1.0_dp)then !BLOOD - viscosity=fluid_properties%blood_viscosity - density=fluid_properties%blood_density + viscosity=fluid%blood_viscosity + density=fluid%blood_density elseif(model_definition(2).eq.2.0_dp)then !AIR - viscosity=fluid_properties%air_viscosity - density=fluid_properties%air_density + viscosity=fluid%air_viscosity + density=fluid%air_density else viscosity=model_definition(3) density=model_definition(4) From c29ddc43562ff4974bb66de6e4c58adacfeb889f Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Fri, 19 Aug 2022 14:05:56 +1200 Subject: [PATCH 24/25] removing DEC$ ATTRIBUTEs from surface_fitting --- src/lib/surface_fitting.f90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/lib/surface_fitting.f90 b/src/lib/surface_fitting.f90 index 3124a008..fb4ed333 100644 --- a/src/lib/surface_fitting.f90 +++ b/src/lib/surface_fitting.f90 @@ -40,7 +40,6 @@ subroutine fit_surface_geometry(niterations,fitting_file) ! data points (3D RC coordinates) and a surface mesh (assumed bi-cubic ! Hermite only). 'fitting_file' lists the nodes/derivatives that are fixed, ! and any mapping of nodes and/or derivatives - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_FIT_SURFACE_GEOMETRY" :: FIT_SURFACE_GEOMETRY integer,intent(in) :: niterations ! user-specified number of fitting iterations character(len=255),intent(in) :: fitting_file ! file that lists versions/mapping/BCs @@ -304,7 +303,7 @@ end subroutine define_geometry_fit subroutine initialise_fit_mesh() !*initialise_fit_mesh:* scale and translate the mesh to align with a data ! cloud. uses the centre of mass and the range of data coordinates. - !DEC$ ATTRIBUTES DLLEXPORT,ALIAS:"SO_INITIALISE_FIT_MESH" :: INITIALISE_FIT_MESH + ! Local variables integer :: i real(dp) :: datacofm(3),meshcofm(3),datarange(3),meshrange(3), & From 336041d1cc58a1607b6af4ac54fe5c233ea71400 Mon Sep 17 00:00:00 2001 From: Merryn Tawhai Date: Thu, 25 Aug 2022 09:24:06 +1200 Subject: [PATCH 25/25] fix to line_segments_for_2d_mesh to use local node index referencing in line_versn_2d not global nodes. seg fault found as part of code review by HK. error picked up using pedantic build --- src/lib/geometry.f90 | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/lib/geometry.f90 b/src/lib/geometry.f90 index 32e1160e..c5da4c0d 100644 --- a/src/lib/geometry.f90 +++ b/src/lib/geometry.f90 @@ -2821,7 +2821,7 @@ subroutine line_segments_for_2d_mesh(sf_option) character(len=4),intent(in) :: sf_option ! Local variables integer :: index_nodes(2,4),j,line_nodes(2),ne,ne_adjacent,ni1,nj, & - nl,nline,nl_adj,nl_found,npn(2),np1,np2,nxi(4) + nl,nline,nl_adj,nl_found,nn1,nn2,npn(2),np1,np2,nxi(4) logical :: MAKE logical :: based_on_elems = .true., found_nl character(len=60) :: sub_name @@ -2864,8 +2864,12 @@ subroutine line_segments_for_2d_mesh(sf_option) do ne = 1,num_elems_2d do nline = 1,4 - np1 = elem_nodes_2d(index_nodes(1,nline),ne) - np2 = elem_nodes_2d(index_nodes(2,nline),ne) +! np1 = elem_nodes_2d(index_nodes(1,nline),ne) +! np2 = elem_nodes_2d(index_nodes(2,nline),ne) + nn1 = index_nodes(1,nline) + nn2 = index_nodes(2,nline) + np1 = elem_nodes_2d(nn1,ne) + np2 = elem_nodes_2d(nn2,ne) found_nl = .false. if(np1.ne.np2)then do nl = 1,num_lines_2d @@ -2889,8 +2893,10 @@ subroutine line_segments_for_2d_mesh(sf_option) nodes_in_line(1,0,num_lines_2d) = nxi(nline) do nj = 1,3 nodes_in_line(1,nj,num_lines_2d) = 4 !type of basis function (1 for linear,4 for cubicHermite) - line_versn_2d(1,nj,num_lines_2d) = elem_versn_2d(np1,ne) - line_versn_2d(2,nj,num_lines_2d) = elem_versn_2d(np2,ne) +! line_versn_2d(1,nj,num_lines_2d) = elem_versn_2d(np1,ne) +! line_versn_2d(2,nj,num_lines_2d) = elem_versn_2d(np2,ne) + line_versn_2d(1,nj,num_lines_2d) = elem_versn_2d(nn1,ne) + line_versn_2d(2,nj,num_lines_2d) = elem_versn_2d(nn2,ne) enddo !nj endif enddo !nline