diff --git a/src/Utilities/Export/DisNCMesh.f90 b/src/Utilities/Export/DisNCMesh.f90 index 8dfd56f155d..dafec624d32 100644 --- a/src/Utilities/Export/DisNCMesh.f90 +++ b/src/Utilities/Export/DisNCMesh.f90 @@ -27,7 +27,7 @@ module MeshDisModelModule private public :: Mesh2dDisExportType - ! -- UGRID layered mesh (ULM) DIS + ! UGRID layered mesh (ULM) DIS type, extends(Mesh2dModelType) :: Mesh2dDisExportType type(DisType), pointer :: dis => null() !< pointer to model dis package integer(I4B) :: x_dim !< ncol dimension id @@ -59,14 +59,14 @@ subroutine dis_export_init(this, modelname, modeltype, modelfname, disenum, & integer(I4B), intent(in) :: disenum integer(I4B), intent(in) :: nctype integer(I4B), intent(in) :: iout - ! - ! -- set nlay + + ! set nlay this%nlay = this%dis%nlay - ! + ! allocate var_id arrays allocate (this%var_ids%dependent(this%nlay)) - ! - ! -- initialize base class + + ! initialize base class call this%mesh_init(modelname, modeltype, modelfname, disenum, nctype, iout) end subroutine dis_export_init @@ -74,10 +74,8 @@ end subroutine dis_export_init !< subroutine dis_export_destroy(this) class(Mesh2dDisExportType), intent(inout) :: this - ! deallocate (this%var_ids%dependent) - ! - ! -- destroy base class + ! destroy base class call this%mesh_destroy() call this%NCModelExportType%destroy() end subroutine dis_export_destroy @@ -88,25 +86,25 @@ subroutine df(this) use ConstantsModule, only: MVALIDATE use SimVariablesModule, only: isim_mode class(Mesh2dDisExportType), intent(inout) :: this - ! -- put root group file scope attributes + ! put root group file scope attributes call this%add_global_att() - ! -- define root group dimensions and coordinate variables + ! define root group dimensions and coordinate variables call this%define_dim() - ! -- define mesh variables + ! define mesh variables call this%create_mesh() if (isim_mode /= MVALIDATE) then - ! -- define the dependent variable + ! define the dependent variable call this%define_dependent() end if - ! -- exit define mode + ! exit define mode call nf_verify(nf90_enddef(this%ncid), this%nc_fname) - ! -- create mesh + ! create mesh call this%add_mesh_data() - ! -- define and set package input griddata + ! define and set package input griddata call this%add_pkg_data() - ! -- define and set gridmap variable + ! define and set gridmap variable call this%define_gridmap() - ! -- synchronize file + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine df @@ -120,61 +118,57 @@ subroutine step(this) integer(I4B) :: n, k, nvals integer(I4B), dimension(2) :: dis_shape real(DP), dimension(:, :), pointer, contiguous :: dbl2d - ! - ! -- initialize + + ! initialize nullify (dbl1d) nullify (dbl2d) - ! - ! -- increment step + + ! increment step this%stepcnt = this%stepcnt + 1 - ! + dis_shape(1) = this%dis%ncol * this%dis%nrow dis_shape(2) = this%dis%nlay - ! + nvals = product(dis_shape) - ! - ! -- add data to dependent variable + + ! add data to dependent variable if (size(this%dis%nodeuser) < & size(this%dis%nodereduced)) then - ! - ! -- allocate nodereduced size 1d array + ! allocate nodereduced size 1d array allocate (dbl1d(size(this%dis%nodereduced))) - ! - ! -- initialize DHNOFLO for non-active cells + + ! initialize DHNOFLO for non-active cells dbl1d = DHNOFLO - ! - ! -- update active cells + + ! update active cells do n = 1, size(this%dis%nodereduced) if (this%dis%nodereduced(n) > 0) then dbl1d(n) = this%x(this%dis%nodereduced(n)) end if end do - ! + dbl2d(1:dis_shape(1), 1:dis_shape(2)) => dbl1d(1:nvals) else - ! dbl2d(1:dis_shape(1), 1:dis_shape(2)) => this%x(1:nvals) - ! end if - ! + do k = 1, this%dis%nlay - ! -- extend array with step data + ! extend array with step data call nf_verify(nf90_put_var(this%ncid, & this%var_ids%dependent(k), dbl2d(:, k), & start=(/1, this%stepcnt/), & count=(/(this%dis%ncol * this%dis%nrow), 1/)), & this%nc_fname) end do - ! - ! -- write to time coordinate variable + + ! write to time coordinate variable call nf_verify(nf90_put_var(this%ncid, this%var_ids%time, & totim, start=(/this%stepcnt/)), & this%nc_fname) - ! - ! -- update file + ! update file call nf_verify(nf90_sync(this%ncid), this%nc_fname) - ! - ! --cleanup + + ! cleanup if (associated(dbl1d)) deallocate (dbl1d) nullify (dbl1d) nullify (dbl2d) @@ -191,7 +185,6 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) class(ExportPackageType), pointer, intent(in) :: export_pkg character(len=*), intent(in) :: ilayer_varname integer(I4B), intent(in) :: ilayer - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d @@ -201,40 +194,37 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: n, iparam, nvals logical(LGP) :: ilayer_read - ! - ! -- initialize + + ! initialize nullify (ialayer) ilayer_read = .false. - ! - ! -- set pointer to ilayer variable + + ! set pointer to ilayer variable call mem_setptr(ialayer, export_pkg%param_names(ilayer), & export_pkg%mf6_input%mempath) - ! - ! -- check if layer index variable was read + + ! check if layer index variable was read if (export_pkg%param_reads(ilayer)%invar == 1) then ilayer_read = .true. end if - ! - ! -- export defined period input + + ! export defined period input do iparam = 1, export_pkg%nparam - ! - ! -- check if variable was read this period + ! check if variable was read this period if (export_pkg%param_reads(iparam)%invar < 1) cycle - ! - ! -- set input definition + + ! set input definition idt => & get_param_definition_type(export_pkg%mf6_input%param_dfns, & export_pkg%mf6_input%component_type, & export_pkg%mf6_input%subcomponent_type, & 'PERIOD', export_pkg%param_names(iparam), '') - ! - ! -- set variable name and input string + ! set variable name and input string nc_varname = trim(export_pkg%mf6_input%subcomponent_name)//'_'// & trim(idt%mf6varname) input_attr = this%input_attribute(export_pkg%mf6_input%subcomponent_name, & idt) - ! - ! -- export arrays + ! export arrays select case (idt%datatype) case ('INTEGER1D') call mem_setptr(int1d, idt%mf6varname, export_pkg%mf6_input%mempath) @@ -251,7 +241,7 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) case ('DOUBLE2D') call mem_setptr(dbl2d, idt%mf6varname, export_pkg%mf6_input%mempath) nvals = this%dis%ncol * this%dis%nrow - ! + do n = 1, size(dbl2d, dim=1) !naux dbl1d_ptr(1:nvals) => dbl2d(n, :) if (all(dbl1d_ptr == DZERO)) then @@ -261,17 +251,13 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) end if end do case default - ! errmsg = 'EXPORT ilayaer unsupported datatype='//trim(idt%datatype) call store_error(errmsg, .true.) end select end do - ! - ! -- synchronize file + + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) - ! - ! -- return - return end subroutine package_step_ilayer !> @brief netcdf export package dynamic input @@ -284,8 +270,8 @@ subroutine package_step(this, export_pkg) trim(this%modelname)//', package='// & trim(export_pkg%mf6_input%subcomponent_name) call store_error(errmsg, .true.) - ! - ! -- synchronize file + + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine package_step @@ -304,12 +290,11 @@ subroutine export_layer_3d(this, export_pkg, idt, ilayer_read, ialayer, & character(len=*), intent(in) :: nc_varname character(len=*), intent(in) :: input_attr integer(I4B), optional, intent(in) :: iaux - ! -- local real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d integer(I4B) :: n, i, j, k, nvals, idxaux real(DP), dimension(:, :), contiguous, pointer :: dbl2d_ptr - ! - ! -- initialize + + ! initialize idxaux = 0 if (present(iaux)) then idxaux = iaux @@ -317,7 +302,7 @@ subroutine export_layer_3d(this, export_pkg, idt, ilayer_read, ialayer, & allocate (dbl3d(export_pkg%mshape(3), export_pkg%mshape(2), & export_pkg%mshape(1))) - ! + if (ilayer_read) then do k = 1, size(dbl3d, dim=3) n = 0 @@ -338,7 +323,7 @@ subroutine export_layer_3d(this, export_pkg, idt, ilayer_read, ialayer, & dbl2d_ptr(1:export_pkg%mshape(3), 1:export_pkg%mshape(2)) => dbl1d(1:nvals) dbl3d(:, :, 1) = dbl2d_ptr(:, :) end if - ! + call nc_export_dbl3d(this%ncid, this%dim_ids, this%var_ids, this%dis, dbl3d, & nc_varname, export_pkg%mf6_input%subcomponent_name, & idt%tagname, this%gridmap_name, idt%shape, & @@ -364,15 +349,15 @@ subroutine export_input_array(this, pkgtype, pkgname, mempath, idt) real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: iper, iaux - ! + iper = 0 iaux = 0 - ! - ! -- set package base name + + ! set package base name nc_varname = trim(pkgname)//'_'//trim(idt%mf6varname) - ! -- put input attributes + ! put input attributes input_attr = this%input_attribute(pkgname, idt) - ! + select case (idt%datatype) case ('INTEGER1D') call mem_setptr(int1d, idt%mf6varname, mempath) @@ -417,7 +402,7 @@ subroutine export_input_array(this, pkgtype, pkgname, mempath, idt) input_attr, this%deflate, this%shuffle, & this%chunk_face, iper, iaux, this%nc_fname) case default - ! -- no-op, no other datatypes exported + ! no-op, no other datatypes exported end select end subroutine export_input_array @@ -427,8 +412,8 @@ subroutine define_dim(this) use ConstantsModule, only: MVALIDATE use SimVariablesModule, only: isim_mode class(Mesh2dDisExportType), intent(inout) :: this - ! - ! -- time + + ! time if (isim_mode /= MVALIDATE) then call nf_verify(nf90_def_dim(this%ncid, 'time', this%totnstp, & this%dim_ids%time), this%nc_fname) @@ -446,8 +431,8 @@ subroutine define_dim(this) call nf_verify(nf90_put_att(this%ncid, this%var_ids%time, 'long_name', & 'time'), this%nc_fname) end if - ! - ! -- mesh + + ! mesh call nf_verify(nf90_def_dim(this%ncid, 'nmesh_node', & ((this%dis%ncol + 1) * (this%dis%nrow + 1)), & this%dim_ids%nmesh_node), this%nc_fname) @@ -457,8 +442,8 @@ subroutine define_dim(this) call nf_verify(nf90_def_dim(this%ncid, 'max_nmesh_face_nodes', 4, & this%dim_ids%max_nmesh_face_nodes), & this%nc_fname) - ! - ! -- x, y, nlay + + ! x, y, nlay call nf_verify(nf90_def_dim(this%ncid, 'nlay', this%dis%nlay, & this%dim_ids%nlay), this%nc_fname) call nf_verify(nf90_def_dim(this%ncid, 'x', this%dis%ncol, & @@ -478,23 +463,23 @@ subroutine add_mesh_data(this) real(DP) :: x, y real(DP), dimension(:), allocatable :: node_x, node_y real(DP), dimension(:), allocatable :: cell_x, cell_y - ! - ! -- initialize max vertices required to define cell + + ! initialize max vertices required to define cell maxvert = 4 - ! - ! -- set mesh container variable value to 1 + + ! set mesh container variable value to 1 call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh, 1), & this%nc_fname) - ! - ! -- allocate temporary arrays + + ! allocate temporary arrays allocate (verts(maxvert)) allocate (bnds(maxvert)) allocate (node_x(((this%dis%ncol + 1) * (this%dis%nrow + 1)))) allocate (node_y(((this%dis%ncol + 1) * (this%dis%nrow + 1)))) allocate (cell_x((this%dis%ncol * this%dis%nrow))) allocate (cell_y((this%dis%ncol * this%dis%nrow))) - ! - ! -- set node_x and node_y arrays + + ! set node_x and node_y arrays cnt = 0 node_x = NF90_FILL_DOUBLE node_y = NF90_FILL_DOUBLE @@ -509,14 +494,14 @@ subroutine add_mesh_data(this) end do if (j > 0) y = y - this%dis%delc(j) end do - ! - ! -- write node_x and node_y arrays to netcdf file + + ! write node_x and node_y arrays to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_node_x, node_x), & this%nc_fname) call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_node_y, node_y), & this%nc_fname) - ! - ! -- set cell_x and cell_y arrays + + ! set cell_x and cell_y arrays cnt = 1 cell_x = NF90_FILL_DOUBLE cell_y = NF90_FILL_DOUBLE @@ -530,14 +515,14 @@ subroutine add_mesh_data(this) x = this%dis%cellx(i) + this%dis%xorigin end do end do - ! - ! -- write face_x and face_y arrays to netcdf file + + ! write face_x and face_y arrays to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_x, cell_x), & this%nc_fname) call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_y, cell_y), & this%nc_fname) - ! - ! -- set face nodes array + + ! set face nodes array cnt = 0 do i = 1, this%dis%nrow do j = 1, this%dis%ncol @@ -552,33 +537,33 @@ subroutine add_mesh_data(this) verts(3) = cnt + 1 verts(4) = cnt end if - ! - ! -- write face nodes array to netcdf file + + ! write face nodes array to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_nodes, & verts, start=(/1, cnt/), & count=(/maxvert, 1/)), & this%nc_fname) - ! - ! -- set face y bounds array + + ! set face y bounds array bnds = NF90_FILL_DOUBLE do m = 1, size(bnds) if (verts(m) /= NF90_FILL_INT) then bnds(m) = node_y(verts(m)) end if - ! -- write face y bounds array to netcdf file + ! write face y bounds array to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_ybnds, & bnds, start=(/1, cnt/), & count=(/maxvert, 1/)), & this%nc_fname) end do - ! - ! -- set face x bounds array + + ! set face x bounds array bnds = NF90_FILL_DOUBLE do m = 1, size(bnds) if (verts(m) /= NF90_FILL_INT) then bnds(m) = node_x(verts(m)) end if - ! -- write face x bounds array to netcdf file + ! write face x bounds array to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_xbnds, & bnds, start=(/1, cnt/), & count=(/maxvert, 1/)), & @@ -586,8 +571,8 @@ subroutine add_mesh_data(this) end do end do end do - ! - ! -- cleanup + + ! cleanup deallocate (bnds) deallocate (verts) deallocate (node_x) @@ -621,7 +606,6 @@ subroutine nc_export_int1d(ncid, dim_ids, x_dim, y_dim, var_ids, dis, p_mem, & integer(I4B), intent(in) :: chunk_face integer(I4B), intent(in) :: iper character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(3) :: dis_shape integer(I4B), dimension(1) :: layer_shape integer(I4B), dimension(:, :, :), pointer, contiguous :: int3d @@ -629,11 +613,11 @@ subroutine nc_export_int1d(ncid, dim_ids, x_dim, y_dim, var_ids, dis, p_mem, & integer(I4B) :: axis_dim, nvals, k integer(I4B), dimension(:), allocatable :: var_id character(len=LINELENGTH) :: longname_l, varname_l - ! + if (shapestr == 'NROW' .or. & shapestr == 'NCOL' .or. & shapestr == 'NCPL') then - ! + select case (shapestr) case ('NROW') axis_dim = y_dim @@ -642,84 +626,83 @@ subroutine nc_export_int1d(ncid, dim_ids, x_dim, y_dim, var_ids, dis, p_mem, & case ('NCPL') axis_dim = dim_ids%nmesh_face end select - ! - ! -- set names + + ! set names varname_l = export_varname(nc_varname, layer=0, iper=iper) longname_l = export_longname(longname, pkgname, tagname, layer=0, iper=iper) - ! + allocate (var_id(1)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/axis_dim/), var_id(1)), & nc_fname) - ! - ! -- NROW/NCOL shapes use default chunking + + ! NROW/NCOL shapes use default chunking call ncvar_deflate(ncid, var_id(1), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(1), '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(1), 'long_name', & longname_l), nc_fname) - ! - ! -- add mf6 attr + + ! add mf6 attr call ncvar_mf6attr(ncid, var_id(1), 0, iper, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id(1), p_mem), & nc_fname) else allocate (var_id(dis%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, dis%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k, iper=iper) longname_l = export_longname(longname, pkgname, tagname, layer=k, & iper=iper) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- defalte and shuffle + ! defalte and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, iper, 0, nc_tag, nc_fname) end do - ! - ! -- reshape input + + ! reshape input dis_shape(1) = dis%ncol dis_shape(2) = dis%nrow dis_shape(3) = dis%nlay nvals = product(dis_shape) int3d(1:dis_shape(1), 1:dis_shape(2), 1:dis_shape(3)) => p_mem(1:nvals) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) layer_shape(1) = dis%nrow * dis%ncol do k = 1, dis%nlay int1d(1:layer_shape(1)) => int3d(:, :, k) call nf_verify(nf90_put_var(ncid, var_id(k), int1d), nc_fname) end do - ! - ! -- cleanup + + ! cleanup deallocate (var_id) end if end subroutine nc_export_int1d @@ -745,38 +728,37 @@ subroutine nc_export_int2d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: shuffle integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id integer(I4B), dimension(:), pointer, contiguous :: int1d integer(I4B), dimension(1) :: layer_shape character(len=LINELENGTH) :: longname_l, varname_l - ! - ! -- set names + + ! set names varname_l = export_varname(nc_varname) longname_l = export_longname(longname, pkgname, tagname, 0) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/dim_ids%nmesh_face/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id, chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id, 0, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) layer_shape(1) = dis%nrow * dis%ncol int1d(1:layer_shape(1)) => p_mem @@ -804,52 +786,50 @@ subroutine nc_export_int3d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: shuffle integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(:), allocatable :: var_id integer(I4B), dimension(:), pointer, contiguous :: int1d character(len=LINELENGTH) :: longname_l, varname_l integer(I4B), dimension(1) :: layer_shape integer(I4B) :: k - ! + allocate (var_id(dis%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, dis%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k) longname_l = export_longname(longname, pkgname, tagname, k) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, 0, 0, nc_tag, nc_fname) end do - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) layer_shape(1) = dis%nrow * dis%ncol do k = 1, dis%nlay int1d(1:layer_shape(1)) => p_mem(:, :, k) call nf_verify(nf90_put_var(ncid, var_id(k), int1d), nc_fname) end do - ! - ! -- cleanup + + ! cleanup deallocate (var_id) end subroutine nc_export_int3d @@ -877,7 +857,6 @@ subroutine nc_export_dbl1d(ncid, dim_ids, x_dim, y_dim, var_ids, dis, p_mem, & integer(I4B), intent(in) :: shuffle integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(3) :: dis_shape integer(I4B), dimension(1) :: layer_shape real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d @@ -885,11 +864,11 @@ subroutine nc_export_dbl1d(ncid, dim_ids, x_dim, y_dim, var_ids, dis, p_mem, & integer(I4B) :: axis_dim, nvals, k integer(I4B), dimension(:), allocatable :: var_id character(len=LINELENGTH) :: longname_l, varname_l - ! + if (shapestr == 'NROW' .or. & shapestr == 'NCOL') then ! .or. & !shapestr == 'NCPL') then - ! + select case (shapestr) case ('NROW') axis_dim = y_dim @@ -898,83 +877,82 @@ subroutine nc_export_dbl1d(ncid, dim_ids, x_dim, y_dim, var_ids, dis, p_mem, & !case ('NCPL') ! axis_dim = dim_ids%nmesh_face end select - ! - ! -- set names + + ! set names varname_l = export_varname(nc_varname) longname_l = export_longname(longname, pkgname, tagname, 0) - ! + allocate (var_id(1)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/axis_dim/), var_id(1)), & nc_fname) - ! - ! -- NROW/NCOL shapes use default chunking + + ! NROW/NCOL shapes use default chunking call ncvar_deflate(ncid, var_id(1), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(1), '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(1), 'long_name', & longname_l), nc_fname) - ! - ! -- add mf6 attr + + ! add mf6 attr call ncvar_mf6attr(ncid, var_id(1), 0, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id(1), p_mem), & nc_fname) else allocate (var_id(dis%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, dis%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k) longname_l = export_longname(longname, pkgname, tagname, k) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- defalte and shuffle + ! defalte and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, 0, 0, nc_tag, nc_fname) end do - ! - ! -- reshape input + + ! reshape input dis_shape(1) = dis%ncol dis_shape(2) = dis%nrow dis_shape(3) = dis%nlay nvals = product(dis_shape) dbl3d(1:dis_shape(1), 1:dis_shape(2), 1:dis_shape(3)) => p_mem(1:nvals) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) layer_shape(1) = dis%nrow * dis%ncol do k = 1, dis%nlay dbl1d(1:layer_shape(1)) => dbl3d(:, :, k) call nf_verify(nf90_put_var(ncid, var_id(k), dbl1d), nc_fname) end do - ! - ! -- cleanup + + ! cleanup deallocate (var_id) end if end subroutine nc_export_dbl1d @@ -1000,38 +978,37 @@ subroutine nc_export_dbl2d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: shuffle integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id character(len=LINELENGTH) :: longname_l, varname_l real(DP), dimension(:), pointer, contiguous :: dbl1d integer(I4B), dimension(1) :: layer_shape - ! - ! -- set names + + ! set names varname_l = export_varname(nc_varname) longname_l = export_longname(longname, pkgname, tagname, 0) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/dim_ids%nmesh_face/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id, chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id, 0, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) layer_shape(1) = dis%nrow * dis%ncol dbl1d(1:layer_shape(1)) => p_mem @@ -1063,60 +1040,58 @@ subroutine nc_export_dbl3d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: iper integer(I4B), intent(in) :: iaux character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(:), allocatable :: var_id real(DP), dimension(:), pointer, contiguous :: dbl1d character(len=LINELENGTH) :: longname_l, varname_l integer(I4B), dimension(1) :: layer_shape integer(I4B) :: k real(DP) :: fill_value - ! + if (iper > 0) then fill_value = DNODATA else fill_value = NF90_FILL_DOUBLE end if - ! + allocate (var_id(dis%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, dis%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k, iper=iper, iaux=iaux) longname_l = export_longname(longname, pkgname, tagname, layer=k, iper=iper) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/fill_value/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, iper, iaux, nc_tag, nc_fname) !end if end do - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) layer_shape(1) = dis%nrow * dis%ncol do k = 1, dis%nlay dbl1d(1:layer_shape(1)) => p_mem(:, :, k) call nf_verify(nf90_put_var(ncid, var_id(k), dbl1d), nc_fname) end do - ! - ! -- cleanup + + ! cleanup deallocate (var_id) end subroutine nc_export_dbl3d diff --git a/src/Utilities/Export/DisNCStructured.f90 b/src/Utilities/Export/DisNCStructured.f90 index 0fa9db4688a..3c8c48ed6fe 100644 --- a/src/Utilities/Export/DisNCStructured.f90 +++ b/src/Utilities/Export/DisNCStructured.f90 @@ -103,51 +103,51 @@ subroutine dis_export_init(this, modelname, modeltype, modelfname, disenum, & integer(I4B), intent(in) :: iout integer(I4B) :: k, latsz, lonsz logical(LGP) :: found - ! - ! -- set nlay + + ! set nlay this%nlay = this%dis%nlay - ! - ! -- allocate + + ! allocate allocate (this%chunk_z) allocate (this%chunk_y) allocate (this%chunk_x) allocate (this%layers(this%nlay)) - ! - ! -- initialize + + ! initialize this%chunk_z = -1 this%chunk_y = -1 this%chunk_x = -1 do k = 1, this%nlay this%layers(k) = k end do - ! + this%latlon = .false. - ! - ! -- initialize base class + + ! initialize base class call this%NCModelExportType%init(modelname, modeltype, modelfname, disenum, & nctype, iout) - ! -- update values from input context + ! update values from input context if (this%ncf_mempath /= '') then call mem_set_value(this%chunk_z, 'CHUNK_Z', this%ncf_mempath, found) call mem_set_value(this%chunk_y, 'CHUNK_Y', this%ncf_mempath, found) call mem_set_value(this%chunk_x, 'CHUNK_X', this%ncf_mempath, found) - ! + if (this%chunk_time > 0 .and. this%chunk_z > 0 .and. & this%chunk_y > 0 .and. this%chunk_x > 0) then this%chunking_active = .true. end if - ! + call get_isize('LAT', this%ncf_mempath, latsz) call get_isize('LON', this%ncf_mempath, lonsz) - ! + if (latsz > 0 .and. lonsz > 0) then this%latlon = .true. call mem_setptr(this%lat, 'LAT', this%ncf_mempath) call mem_setptr(this%lon, 'LON', this%ncf_mempath) end if end if - ! - ! -- create the netcdf file + + ! create the netcdf file call nf_verify(nf90_create(this%nc_fname, & IAND(NF90_CLOBBER, NF90_NETCDF4), this%ncid), & this%nc_fname) @@ -158,17 +158,14 @@ end subroutine dis_export_init subroutine dis_export_destroy(this) class(DisNCStructuredType), intent(inout) :: this call nf_verify(nf90_close(this%ncid), this%nc_fname) - ! deallocate (this%chunk_z) deallocate (this%chunk_y) deallocate (this%chunk_x) deallocate (this%layers) - ! nullify (this%chunk_z) nullify (this%chunk_y) nullify (this%chunk_x) - ! - ! -- destroy base class + ! destroy base class call this%NCModelExportType%destroy() end subroutine dis_export_destroy @@ -178,27 +175,27 @@ subroutine df(this) use ConstantsModule, only: MVALIDATE use SimVariablesModule, only: isim_mode class(DisNCStructuredType), intent(inout) :: this - ! -- put root group file scope attributes + ! put root group file scope attributes call this%add_global_att() - ! -- define root group dimensions and coordinate variables + ! define root group dimensions and coordinate variables call this%define_dim() - ! -- define grid projection variables + ! define grid projection variables call this%define_projection() if (isim_mode /= MVALIDATE) then - ! -- define the dependent variable + ! define the dependent variable call this%define_dependent() end if - ! -- exit define mode + ! exit define mode call nf_verify(nf90_enddef(this%ncid), this%nc_fname) - ! -- add data locations + ! add data locations call this%add_grid_data() - ! -- add projection data + ! add projection data call this%add_proj_data() - ! -- define and set package input griddata + ! define and set package input griddata call this%add_pkg_data() - ! -- define and set gridmap variable + ! define and set gridmap variable call this%define_gridmap() - ! -- synchronize file + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine df @@ -210,9 +207,9 @@ subroutine step(this) class(DisNCStructuredType), intent(inout) :: this real(DP), dimension(:), pointer, contiguous :: dbl1d integer(I4B) :: n - ! + this%stepcnt = this%stepcnt + 1 - ! + if (size(this%dis%nodeuser) < & size(this%dis%nodereduced)) then allocate (dbl1d(size(this%dis%nodereduced))) @@ -222,7 +219,7 @@ subroutine step(this) dbl1d(n) = this%x(this%dis%nodereduced(n)) end if end do - ! -- write step data to dependent variable + ! write step data to dependent variable call nf_verify(nf90_put_var(this%ncid, & this%var_ids%dependent, dbl1d, & start=(/1, 1, 1, this%stepcnt/), & @@ -232,7 +229,7 @@ subroutine step(this) this%nc_fname) deallocate (dbl1d) else - ! -- write step data to dependent variable + ! write step data to dependent variable call nf_verify(nf90_put_var(this%ncid, & this%var_ids%dependent, this%x, & start=(/1, 1, 1, this%stepcnt/), & @@ -241,12 +238,13 @@ subroutine step(this) this%dis%nlay, 1/)), & this%nc_fname) end if - ! - ! -- write to time coordinate variable + + ! write to time coordinate variable call nf_verify(nf90_put_var(this%ncid, this%var_ids%time, & totim, start=(/this%stepcnt/)), & this%nc_fname) - ! -- synchronize file + + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine step @@ -266,15 +264,15 @@ subroutine export_input_array(this, pkgtype, pkgname, mempath, idt) real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: iper, iaux - ! - ! -- initialize + + ! initialize iper = 0 iaux = 0 - ! - ! -- set variable name and input attribute string + + ! set variable name and input attribute string nc_varname = export_varname(pkgname, idt) input_attr = this%input_attribute(pkgname, idt) - ! + select case (idt%datatype) case ('INTEGER1D') call mem_setptr(int1d, idt%mf6varname, mempath) @@ -325,7 +323,7 @@ subroutine export_input_array(this, pkgtype, pkgname, mempath, idt) this%shuffle, this%chunk_z, this%chunk_y, & this%chunk_x, iper, iaux, this%nc_fname) case default - ! -- no-op, no other datatypes exported + ! no-op, no other datatypes exported end select end subroutine export_input_array @@ -341,15 +339,13 @@ subroutine export_input_arrays(this, pkgtype, pkgname, mempath, param_dfns) intent(in) :: param_dfns type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iparam, isize - ! do iparam = 1, size(param_dfns) - ! -- assign param definition pointer + ! assign param definition pointer idt => param_dfns(iparam) - ! -- for now + ! for now only griddata is exported if (idt%blockname == 'GRIDDATA') then - ! -- check if variable is already allocated + ! check if variable is already allocated call get_isize(idt%mf6varname, mempath, isize) - ! if (isize > 0) then call this%export_input_array(pkgtype, pkgname, mempath, idt) end if @@ -369,7 +365,6 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) character(len=*), intent(in) :: ilayer_varname integer(I4B), intent(in) :: ilayer type(InputParamDefinitionType), pointer :: idt - ! -- local integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d real(DP), dimension(:, :), pointer, contiguous :: dbl2d @@ -378,41 +373,38 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: n, iparam, nvals logical(LGP) :: ilayer_read - ! - ! -- initialize + + ! initialize nullify (ialayer) ilayer_read = .false. - ! - ! -- set pointer to ilayer variable + + ! set pointer to ilayer variable call mem_setptr(ialayer, export_pkg%param_names(ilayer), & export_pkg%mf6_input%mempath) - ! - ! -- check if layer index variable was read + + ! check if layer index variable was read if (export_pkg%param_reads(ilayer)%invar == 1) then ilayer_read = .true. end if - ! - ! -- export defined period input + + ! export defined period input do iparam = 1, export_pkg%nparam - ! - ! -- check if variable was read this period + ! check if variable was read this period if (export_pkg%param_reads(iparam)%invar < 1) cycle - ! - ! -- set input definition + + ! set input definition idt => & get_param_definition_type(export_pkg%mf6_input%param_dfns, & export_pkg%mf6_input%component_type, & export_pkg%mf6_input%subcomponent_type, & 'PERIOD', export_pkg%param_names(iparam), & this%nc_fname) - ! - ! -- set variable name and input attrs + ! set variable name and input attrs nc_varname = export_varname(export_pkg%mf6_input%subcomponent_name, idt, & iper=kper) input_attr = this%input_attribute(export_pkg%mf6_input%subcomponent_name, & idt) - ! - ! -- export arrays + ! export arrays select case (idt%datatype) case ('INTEGER1D') call mem_setptr(int1d, idt%mf6varname, export_pkg%mf6_input%mempath) @@ -430,7 +422,6 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) case ('DOUBLE2D') call mem_setptr(dbl2d, idt%mf6varname, export_pkg%mf6_input%mempath) nvals = this%dis%ncol * this%dis%nrow - ! do n = 1, size(dbl2d, dim=1) ! naux dbl1d_ptr(1:nvals) => dbl2d(n, :) if (all(dbl1d_ptr == DZERO)) then @@ -440,17 +431,13 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) end if end do case default - ! errmsg = 'EXPORT ilayer unsupported datatype='//trim(idt%datatype) call store_error(errmsg, .true.) end select end do - ! - ! -- synchronize file + + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) - ! - ! -- return - return end subroutine package_step_ilayer !> @brief netcdf export package dynamic input @@ -466,26 +453,24 @@ subroutine package_step(this, export_pkg) type(InputParamDefinitionType), pointer :: idt character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: iparam - ! + do iparam = 1, export_pkg%nparam - ! - ! -- set input definition + ! set input definition idt => get_param_definition_type(export_pkg%mf6_input%param_dfns, & export_pkg%mf6_input%component_type, & export_pkg%mf6_input%subcomponent_type, & 'PERIOD', export_pkg%param_names(iparam), & this%nc_fname) - ! - ! -- set variable name and input attribute string + + ! set variable name and input attribute string nc_varname = export_varname(export_pkg%mf6_input%subcomponent_name, idt, & iper=kper) input_attr = this%input_attribute(export_pkg%mf6_input%subcomponent_name, & idt) - ! - ! -- export arrays + + ! export arrays select case (idt%datatype) case ('INTEGER1D') - ! call mem_setptr(int1d, export_pkg%param_names(iparam), & export_pkg%mf6_input%mempath) call nc_export_array(this%ncid, this%dim_ids, this%var_ids, this%dis, & @@ -495,9 +480,7 @@ subroutine package_step(this, export_pkg) this%gridmap_name, this%latlon, this%deflate, & this%shuffle, this%chunk_z, this%chunk_y, & this%chunk_x, kper, this%nc_fname) - ! case ('DOUBLE1D') - ! call mem_setptr(dbl1d, export_pkg%param_names(iparam), & export_pkg%mf6_input%mempath) call nc_export_array(this%ncid, this%dim_ids, this%var_ids, this%dis, & @@ -507,16 +490,13 @@ subroutine package_step(this, export_pkg) this%gridmap_name, this%latlon, this%deflate, & this%shuffle, this%chunk_z, this%chunk_y, & this%chunk_x, kper, this%nc_fname) - ! case default - ! errmsg = 'EXPORT unsupported datatype='//trim(idt%datatype) call store_error(errmsg, .true.) - ! end select end do - ! - ! -- synchronize file + + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine package_step @@ -536,12 +516,11 @@ subroutine export_layer_3d(this, export_pkg, idt, ilayer_read, ialayer, & character(len=*), intent(inout) :: nc_varname character(len=*), intent(in) :: input_attr integer(I4B), optional, intent(in) :: iaux - ! -- local real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d integer(I4B) :: n, i, j, k, nvals, idxaux real(DP), dimension(:, :), contiguous, pointer :: dbl2d_ptr - ! - ! -- initialize + + ! initialize idxaux = 0 if (present(iaux)) then nc_varname = export_varname(export_pkg%mf6_input%subcomponent_name, & @@ -551,7 +530,7 @@ subroutine export_layer_3d(this, export_pkg, idt, ilayer_read, ialayer, & allocate (dbl3d(export_pkg%mshape(3), export_pkg%mshape(2), & export_pkg%mshape(1))) - ! + if (ilayer_read) then do k = 1, size(dbl3d, dim=3) n = 0 @@ -572,7 +551,7 @@ subroutine export_layer_3d(this, export_pkg, idt, ilayer_read, ialayer, & dbl2d_ptr(1:export_pkg%mshape(3), 1:export_pkg%mshape(2)) => dbl1d(1:nvals) dbl3d(:, :, 1) = dbl2d_ptr(:, :) end if - ! + call nc_export_array(this%ncid, this%dim_ids, this%var_ids, this%dis, dbl3d, & nc_varname, export_pkg%mf6_input%subcomponent_name, & idt%tagname, idt%shape, idt%longname, input_attr, & @@ -604,38 +583,37 @@ subroutine add_pkg_data(this) integer(I4B) :: n integer(I4B), pointer :: export_arrays logical(LGP) :: found - ! + input_mempath = create_mem_path(component=this%modelname, context=idm_context) - ! - ! -- set pointers to model path package info + + ! set pointers to model path package info call mem_setptr(pkgtypes, 'PKGTYPES', input_mempath) call mem_setptr(pkgnames, 'PKGNAMES', input_mempath) call mem_setptr(mempaths, 'MEMPATHS', input_mempath) - ! + do n = 1, size(mempaths) - ! - ! -- allocate export_arrays + ! allocate export_arrays allocate (export_arrays) export_arrays = 0 - ! - ! -- set package attributes + + ! set package attributes mempath = mempaths(n) pname = pkgnames(n) ptype = pkgtypes(n) - ! - ! -- export input arrays + + ! export input arrays if (mempath /= '') then - ! -- update export + ! update export call mem_set_value(export_arrays, 'EXPORT_NC', mempath, found) - ! + if (export_arrays > 0) then pkgtype = idm_subcomponent_type(this%modeltype, ptype) param_dfns => param_definitions(this%modeltype, pkgtype) call this%export_input_arrays(ptype, pname, mempath, param_dfns) end if end if - ! - ! -- cleanup + + ! cleanup deallocate (export_arrays) end do end subroutine add_pkg_data @@ -644,22 +622,22 @@ end subroutine add_pkg_data !< subroutine add_global_att(this) class(DisNCStructuredType), intent(inout) :: this - ! -- file scoped title + ! file scoped title call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'title', & this%annotation%title), this%nc_fname) - ! -- source (MODFLOW 6) + ! source (MODFLOW 6) call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'source', & this%annotation%source), this%nc_fname) - ! -- export type (MODFLOW 6) + ! export type (MODFLOW 6) call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'modflow6_grid', & this%annotation%grid), this%nc_fname) - ! -- MODFLOW 6 model type + ! MODFLOW 6 model type call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'modflow6_model', & this%annotation%model), this%nc_fname) - ! -- generation datetime + ! generation datetime call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'history', & this%annotation%history), this%nc_fname) - ! -- supported conventions + ! supported conventions call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'Conventions', & this%annotation%conventions), & this%nc_fname) @@ -675,8 +653,8 @@ subroutine define_dim(this) ! bound dim call nf_verify(nf90_def_dim(this%ncid, 'bnd', 2, this%dim_ids%bnd), & this%nc_fname) - ! - ! -- Time + + ! Time if (isim_mode /= MVALIDATE) then call nf_verify(nf90_def_dim(this%ncid, 'time', this%totnstp, & this%dim_ids%time), this%nc_fname) @@ -695,8 +673,8 @@ subroutine define_dim(this) call nf_verify(nf90_put_att(this%ncid, this%var_ids%time, 'long_name', & 'time'), this%nc_fname) end if - ! - ! -- Z dimension + + ! Z dimension call nf_verify(nf90_def_dim(this%ncid, 'z', this%dis%nlay, this%dim_ids%z), & this%nc_fname) call nf_verify(nf90_def_var(this%ncid, 'z', NF90_DOUBLE, this%dim_ids%z, & @@ -712,8 +690,8 @@ subroutine define_dim(this) ! this%var_ids%z_bnds), this%nc_fname) !call nf_verify(nf90_put_var(this%ncid, this%var_ids%z_bnds, & ! this%elev_bnds), this%nc_fname) - ! - ! -- Y dimension + + ! Y dimension call nf_verify(nf90_def_dim(this%ncid, 'y', this%dis%nrow, this%dim_ids%y), & this%nc_fname) call nf_verify(nf90_def_var(this%ncid, 'y', NF90_DOUBLE, this%dim_ids%y, & @@ -735,8 +713,8 @@ subroutine define_dim(this) call nf_verify(nf90_def_var(this%ncid, 'y_bnds', NF90_DOUBLE, & (/this%dim_ids%bnd, this%dim_ids%y/), & this%var_ids%y_bnds), this%nc_fname) - ! - ! -- X dimension + + ! X dimension call nf_verify(nf90_def_dim(this%ncid, 'x', this%dis%ncol, this%dim_ids%x), & this%nc_fname) call nf_verify(nf90_def_var(this%ncid, 'x', NF90_DOUBLE, this%dim_ids%x, & @@ -759,8 +737,7 @@ subroutine define_dim(this) (/this%dim_ids%bnd, this%dim_ids%x/), & this%var_ids%x_bnds), this%nc_fname) - ! - ! -- NCPL dimension + ! NCPL dimension call nf_verify(nf90_def_dim(this%ncid, 'ncpl', & this%dis%ncol * this%dis%nrow, & this%dim_ids%ncpl), this%nc_fname) @@ -771,13 +748,14 @@ end subroutine define_dim subroutine define_dependent(this) use ConstantsModule, only: DHNOFLO class(DisNCStructuredType), intent(inout) :: this - ! + call nf_verify(nf90_def_var(this%ncid, this%xname, NF90_DOUBLE, & (/this%dim_ids%x, this%dim_ids%y, & this%dim_ids%z, this%dim_ids%time/), & this%var_ids%dependent), & this%nc_fname) - ! -- apply chunking parameters + + ! apply chunking parameters if (this%chunking_active) then call nf_verify(nf90_def_var_chunking(this%ncid, & this%var_ids%dependent, & @@ -786,11 +764,12 @@ subroutine define_dependent(this) this%chunk_z, this%chunk_time/)), & this%nc_fname) end if - ! -- deflate and shuffle + + ! deflate and shuffle call ncvar_deflate(this%ncid, this%var_ids%dependent, this%deflate, & this%shuffle, this%nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(this%ncid, this%var_ids%dependent, & 'units', 'm'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%dependent, & @@ -800,8 +779,8 @@ subroutine define_dependent(this) this%annotation%longname), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%dependent, '_FillValue', & (/DHNOFLO/)), this%nc_fname) - ! - ! -- add grid mapping + + ! add grid mapping call ncvar_gridmap(this%ncid, this%var_ids%dependent, this%gridmap_name, & this%latlon, this%nc_fname) end subroutine define_dependent @@ -815,7 +794,7 @@ subroutine define_gridmap(this) call nf_verify(nf90_redef(this%ncid), this%nc_fname) call nf_verify(nf90_def_var(this%ncid, this%gridmap_name, NF90_INT, & var_id), this%nc_fname) - ! -- TODO: consider variants epsg_code, spatial_ref, esri_pe_string, wkt, etc + ! TODO: consider variants epsg_code, spatial_ref, esri_pe_string, wkt, etc call nf_verify(nf90_put_att(this%ncid, var_id, 'crs_wkt', this%ogc_wkt), & this%nc_fname) call nf_verify(nf90_enddef(this%ncid), this%nc_fname) @@ -829,7 +808,7 @@ end subroutine define_gridmap subroutine define_projection(this) class(DisNCStructuredType), intent(inout) :: this if (this%latlon .and. this%ogc_wkt /= '') then - ! -- lat + ! lat call nf_verify(nf90_def_var(this%ncid, 'lat', NF90_DOUBLE, & (/this%dim_ids%x, this%dim_ids%y/), & this%var_ids%lat), this%nc_fname) @@ -839,8 +818,8 @@ subroutine define_projection(this) 'latitude'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%lat, 'long_name', & 'latitude'), this%nc_fname) - ! - ! -- lon + + ! lon call nf_verify(nf90_def_var(this%ncid, 'lon', NF90_DOUBLE, & (/this%dim_ids%x, this%dim_ids%y/), & this%var_ids%lon), this%nc_fname) @@ -858,14 +837,13 @@ end subroutine define_projection subroutine add_proj_data(this) class(DisNCStructuredType), intent(inout) :: this if (this%latlon .and. this%ogc_wkt /= '') then - ! -- lat - ! + ! lat call nf_verify(nf90_put_var(this%ncid, this%var_ids%lat, & this%lat, start=(/1, 1/), & count=(/this%dis%ncol, this%dis%nrow/)), & this%nc_fname) - ! -- lon - ! + + ! lon call nf_verify(nf90_put_var(this%ncid, this%var_ids%lon, & this%lon, start=(/1, 1/), & count=(/this%dis%ncol, this%dis%nrow/)), & @@ -880,7 +858,7 @@ subroutine add_grid_data(this) integer(I4B) :: ibnd, n !, k, i, j real(DP), dimension(:, :), pointer, contiguous :: dbl2d real(DP), dimension(:), allocatable :: x, y - ! + allocate (x(size(this%dis%cellx))) allocate (y(size(this%dis%celly))) @@ -896,15 +874,14 @@ subroutine add_grid_data(this) this%nc_fname) call nf_verify(nf90_put_var(this%ncid, this%var_ids%y, y), & this%nc_fname) - ! -- TODO see cf-conventions 4.3.3. Parametric Vertical Coordinate + ! TODO see cf-conventions 4.3.3. Parametric Vertical Coordinate call nf_verify(nf90_put_var(this%ncid, this%var_ids%z, this%layers), & this%nc_fname) deallocate (x) deallocate (y) - ! - ! -- bounds x + ! bounds x allocate (dbl2d(2, size(this%dis%cellx))) ibnd = 1 do n = 1, size(this%dis%cellx) @@ -921,7 +898,7 @@ subroutine add_grid_data(this) this%nc_fname) deallocate (dbl2d) - ! -- bounds y + ! bounds y allocate (dbl2d(2, size(this%dis%celly))) ibnd = 1 do n = size(this%dis%celly), 1, -1 @@ -947,7 +924,6 @@ subroutine ncvar_chunk2d(ncid, varid, chunk_x, chunk_y, nc_fname) integer(I4B), intent(in) :: chunk_x integer(I4B), intent(in) :: chunk_y character(len=*), intent(in) :: nc_fname - ! if (chunk_y > 0 .and. chunk_x > 0) then call nf_verify(nf90_def_var_chunking(ncid, varid, NF90_CHUNKED, & (/chunk_x, chunk_y/)), nc_fname) @@ -963,7 +939,6 @@ subroutine ncvar_chunk3d(ncid, varid, chunk_x, chunk_y, chunk_z, nc_fname) integer(I4B), intent(in) :: chunk_y integer(I4B), intent(in) :: chunk_z character(len=*), intent(in) :: nc_fname - ! if (chunk_z > 0 .and. chunk_y > 0 .and. chunk_x > 0) then call nf_verify(nf90_def_var_chunking(ncid, varid, NF90_CHUNKED, & (/chunk_x, chunk_y, chunk_z/)), & @@ -979,7 +954,7 @@ subroutine ncvar_deflate(ncid, varid, deflate, shuffle, nc_fname) integer(I4B), intent(in) :: deflate integer(I4B), intent(in) :: shuffle character(len=*), intent(in) :: nc_fname - ! -- deflate and shuffle + ! deflate and shuffle if (deflate >= 0) then call nf_verify(nf90_def_var_deflate(ncid, varid, shuffle=shuffle, & deflate=1, deflate_level=deflate), & @@ -995,7 +970,6 @@ subroutine ncvar_gridmap(ncid, varid, gridmap_name, latlon, nc_fname) character(len=*), intent(in) :: gridmap_name logical(LGP), intent(in) :: latlon character(len=*), intent(in) :: nc_fname - ! if (gridmap_name /= '') then if (latlon) then call nf_verify(nf90_put_att(ncid, varid, 'coordinates', 'lon lat'), & @@ -1018,7 +992,6 @@ subroutine ncvar_mf6attr(ncid, varid, iper, iaux, nc_tag, nc_fname) integer(I4B), intent(in) :: iaux character(len=*), intent(in) :: nc_tag character(len=*), intent(in) :: nc_fname - ! if (nc_tag /= '') then call nf_verify(nf90_put_att(ncid, varid, 'modflow6_input', & nc_tag), nc_fname) @@ -1026,7 +999,6 @@ subroutine ncvar_mf6attr(ncid, varid, iper, iaux, nc_tag, nc_fname) call nf_verify(nf90_put_att(ncid, varid, 'modflow6_iper', & iper), nc_fname) end if - ! if (iaux > 0) then call nf_verify(nf90_put_att(ncid, varid, 'modflow6_iaux', & iaux), nc_fname) @@ -1060,14 +1032,13 @@ subroutine nc_export_int1d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: chunk_x integer(I4B), intent(in) :: iper character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id, axis_sz character(len=LINELENGTH) :: longname_l - ! + if (shapestr == 'NROW' .or. & shapestr == 'NCOL' .or. & shapestr == 'NCPL') then - ! + select case (shapestr) case ('NROW') axis_sz = dim_ids%y @@ -1076,56 +1047,55 @@ subroutine nc_export_int1d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & case ('NCPL') axis_sz = dim_ids%ncpl end select - ! + longname_l = export_longname(longname, pkgname, tagname, layer=0, iper=iper) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_INT, & (/axis_sz/), var_id), & nc_fname) - ! - ! -- NROW/NCOL shapes use default chunking + + ! NROW/NCOL shapes use default chunking call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname_l), nc_fname) - ! - ! -- add mf6 attr + + ! add mf6 attr call ncvar_mf6attr(ncid, var_id, iper, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem), & nc_fname) else - ! - ! -- reenter define mode and create variable + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_INT, & (/dim_ids%x, dim_ids%y, dim_ids%z/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk3d(ncid, var_id, chunk_x, chunk_y, chunk_z, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, latlon, nc_fname) call ncvar_mf6attr(ncid, var_id, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem, start=(/1, 1, 1/), & count=(/dis%ncol, dis%nrow, dis%nlay/)), & @@ -1158,31 +1128,30 @@ subroutine nc_export_int2d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: chunk_y integer(I4B), intent(in) :: chunk_x character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_INT, & (/dim_ids%x, dim_ids%y/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk2d(ncid, var_id, chunk_x, chunk_y, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, latlon, nc_fname) call ncvar_mf6attr(ncid, var_id, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem, start=(/1, 1/), & count=(/dis%ncol, dis%nrow/)), & @@ -1214,31 +1183,30 @@ subroutine nc_export_int3d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: chunk_y integer(I4B), intent(in) :: chunk_x character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_INT, & (/dim_ids%x, dim_ids%y, dim_ids%z/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk3d(ncid, var_id, chunk_x, chunk_y, chunk_z, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, latlon, nc_fname) call ncvar_mf6attr(ncid, var_id, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem, start=(/1, 1, 1/), & count=(/dis%ncol, dis%nrow, dis%nlay/)), & @@ -1272,15 +1240,14 @@ subroutine nc_export_dbl1d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: chunk_x integer(I4B), intent(in) :: iper character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id, axis_sz real(DP) :: fill_value character(len=LINELENGTH) :: longname_l - ! + if (shapestr == 'NROW' .or. & shapestr == 'NCOL' .or. & shapestr == 'NCPL') then - ! + select case (shapestr) case ('NROW') axis_sz = dim_ids%y @@ -1289,62 +1256,61 @@ subroutine nc_export_dbl1d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & case ('NCPL') axis_sz = dim_ids%ncpl end select - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_DOUBLE, & (/axis_sz/), var_id), & nc_fname) - ! - ! -- NROW/NCOL shapes use default chunking + + ! NROW/NCOL shapes use default chunking call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname), nc_fname) - ! - ! -- add mf6 attr + + ! add mf6 attr call ncvar_mf6attr(ncid, var_id, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem), & nc_fname) else - ! if (iper > 0) then fill_value = DNODATA else fill_value = NF90_FILL_DOUBLE end if - ! + longname_l = export_longname(longname, pkgname, tagname, layer=0, iper=iper) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_DOUBLE, & (/dim_ids%x, dim_ids%y, dim_ids%z/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk3d(ncid, var_id, chunk_x, chunk_y, chunk_z, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/fill_value/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, latlon, nc_fname) call ncvar_mf6attr(ncid, var_id, iper, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem, start=(/1, 1, 1/), & count=(/dis%ncol, dis%nrow, dis%nlay/)), & @@ -1377,31 +1343,30 @@ subroutine nc_export_dbl2d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: chunk_y integer(I4B), intent(in) :: chunk_x character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_DOUBLE, & (/dim_ids%x, dim_ids%y/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk2d(ncid, var_id, chunk_x, chunk_y, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, latlon, nc_fname) call ncvar_mf6attr(ncid, var_id, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem, start=(/1, 1/), & count=(/dis%ncol, dis%nrow/)), & @@ -1436,41 +1401,40 @@ subroutine nc_export_dbl3d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: iper integer(I4B), intent(in) :: iaux character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B) :: var_id real(DP) :: fill_value character(len=LINELENGTH) :: longname_l - ! + if (iper > 0) then fill_value = DNODATA else fill_value = NF90_FILL_DOUBLE end if - ! + longname_l = export_longname(longname, pkgname, tagname, layer=0, iper=iper) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, nc_varname, NF90_DOUBLE, & (/dim_ids%x, dim_ids%y, dim_ids%z/), var_id), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk3d(ncid, var_id, chunk_x, chunk_y, chunk_z, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id, deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id, '_FillValue', & (/fill_value/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id, 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id, gridmap_name, latlon, nc_fname) call ncvar_mf6attr(ncid, var_id, iper, iaux, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id, p_mem, start=(/1, 1, 1/), & count=(/dis%ncol, dis%nrow, dis%nlay/)), & @@ -1487,7 +1451,6 @@ function export_varname(pkgname, idt, iper, iaux) result(varname) integer(I4B), optional, intent(in) :: iaux character(len=LINELENGTH) :: varname character(len=LINELENGTH) :: pname, vname - ! pname = pkgname vname = idt%mf6varname call lowcase(pname) diff --git a/src/Utilities/Export/DisvNCMesh.f90 b/src/Utilities/Export/DisvNCMesh.f90 index 92655c7b380..cc8b59bd22e 100644 --- a/src/Utilities/Export/DisvNCMesh.f90 +++ b/src/Utilities/Export/DisvNCMesh.f90 @@ -27,7 +27,7 @@ module MeshDisvModelModule private public :: Mesh2dDisvExportType - ! -- UGRID layered mesh DISV + ! UGRID layered mesh DISV type, extends(Mesh2dModelType) :: Mesh2dDisvExportType type(DisvType), pointer :: disv => null() !< pointer to model disv package contains @@ -57,14 +57,14 @@ subroutine disv_export_init(this, modelname, modeltype, modelfname, disenum, & integer(I4B), intent(in) :: disenum integer(I4B), intent(in) :: nctype integer(I4B), intent(in) :: iout - ! - ! -- set nlay + + ! set nlay this%nlay = this%disv%nlay - ! + ! allocate var_id arrays allocate (this%var_ids%dependent(this%nlay)) - ! - ! -- initialize base class + + ! initialize base class call this%mesh_init(modelname, modeltype, modelfname, disenum, nctype, iout) end subroutine disv_export_init @@ -72,10 +72,8 @@ end subroutine disv_export_init !< subroutine disv_export_destroy(this) class(Mesh2dDisvExportType), intent(inout) :: this - ! deallocate (this%var_ids%dependent) - ! - ! -- destroy base class + ! destroy base class call this%mesh_destroy() call this%NCModelExportType%destroy() end subroutine disv_export_destroy @@ -86,25 +84,25 @@ subroutine df(this) use ConstantsModule, only: MVALIDATE use SimVariablesModule, only: isim_mode class(Mesh2dDisvExportType), intent(inout) :: this - ! -- put root group file scope attributes + ! put root group file scope attributes call this%add_global_att() - ! -- define root group dimensions and coordinate variables + ! define root group dimensions and coordinate variables call this%define_dim() - ! -- define mesh variables + ! define mesh variables call this%create_mesh() if (isim_mode /= MVALIDATE) then - ! -- define the dependent variable + ! define the dependent variable call this%define_dependent() end if - ! -- exit define mode + ! exit define mode call nf_verify(nf90_enddef(this%ncid), this%nc_fname) - ! -- create mesh + ! create mesh call this%add_mesh_data() - ! -- define and set package input griddata + ! define and set package input griddata call this%add_pkg_data() - ! -- define and set gridmap variable + ! define and set gridmap variable call this%define_gridmap() - ! -- synchronize file + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine df @@ -118,61 +116,58 @@ subroutine step(this) integer(I4B) :: n, k, nvals integer(I4B), dimension(2) :: dis_shape real(DP), dimension(:, :), pointer, contiguous :: dbl2d - ! - ! -- initialize + + ! initialize nullify (dbl1d) nullify (dbl2d) - ! - ! -- increment step + + ! increment step this%stepcnt = this%stepcnt + 1 - ! + dis_shape(1) = this%disv%ncpl dis_shape(2) = this%disv%nlay - ! + nvals = product(dis_shape) - ! - ! -- add data to dependent variable + + ! add data to dependent variable if (size(this%disv%nodeuser) < & size(this%disv%nodereduced)) then - ! - ! -- allocate nodereduced size 1d array + ! allocate nodereduced size 1d array allocate (dbl1d(size(this%disv%nodereduced))) - ! - ! -- initialize DHNOFLO for non-active cells + + ! initialize DHNOFLO for non-active cells dbl1d = DHNOFLO - ! - ! -- update active cells + + ! update active cells do n = 1, size(this%disv%nodereduced) if (this%disv%nodereduced(n) > 0) then dbl1d(n) = this%x(this%disv%nodereduced(n)) end if end do - ! + dbl2d(1:dis_shape(1), 1:dis_shape(2)) => dbl1d(1:nvals) else - ! dbl2d(1:dis_shape(1), 1:dis_shape(2)) => this%x(1:nvals) - ! end if - ! + do k = 1, this%disv%nlay - ! -- extend array with step data + ! extend array with step data call nf_verify(nf90_put_var(this%ncid, & this%var_ids%dependent(k), dbl2d(:, k), & start=(/1, this%stepcnt/), & count=(/this%disv%ncpl, 1/)), & this%nc_fname) end do - ! - ! -- write to time coordinate variable + + ! write to time coordinate variable call nf_verify(nf90_put_var(this%ncid, this%var_ids%time, & totim, start=(/this%stepcnt/)), & this%nc_fname) - ! - ! -- update file + + ! update file call nf_verify(nf90_sync(this%ncid), this%nc_fname) - ! - ! -- cleanup + + ! cleanup if (associated(dbl1d)) deallocate (dbl1d) nullify (dbl1d) nullify (dbl2d) @@ -189,7 +184,6 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) class(ExportPackageType), pointer, intent(in) :: export_pkg character(len=*), intent(in) :: ilayer_varname integer(I4B), intent(in) :: ilayer - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d @@ -199,40 +193,39 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: n, iparam, nvals logical(LGP) :: ilayer_read - ! - ! -- initialize + + ! initialize nullify (ialayer) ilayer_read = .false. - ! - ! -- set pointer to ilayer variable + + ! set pointer to ilayer variable call mem_setptr(ialayer, export_pkg%param_names(ilayer), & export_pkg%mf6_input%mempath) - ! - ! -- check if layer index variable was read + + ! check if layer index variable was read if (export_pkg%param_reads(ilayer)%invar == 1) then ilayer_read = .true. end if - ! - ! -- export defined period input + + ! export defined period input do iparam = 1, export_pkg%nparam - ! - ! -- check if variable was read this period + ! check if variable was read this period if (export_pkg%param_reads(iparam)%invar < 1) cycle - ! - ! -- set input definition + + ! set input definition idt => & get_param_definition_type(export_pkg%mf6_input%param_dfns, & export_pkg%mf6_input%component_type, & export_pkg%mf6_input%subcomponent_type, & 'PERIOD', export_pkg%param_names(iparam), '') - ! - ! -- set variable name and input string + + ! set variable name and input string nc_varname = trim(export_pkg%mf6_input%subcomponent_name)//'_'// & trim(idt%mf6varname) input_attr = this%input_attribute(export_pkg%mf6_input%subcomponent_name, & idt) - ! - ! -- export arrays + + ! export arrays select case (idt%datatype) case ('INTEGER1D') call mem_setptr(int1d, idt%mf6varname, export_pkg%mf6_input%mempath) @@ -249,7 +242,6 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) case ('DOUBLE2D') call mem_setptr(dbl2d, idt%mf6varname, export_pkg%mf6_input%mempath) nvals = this%disv%ncpl - ! do n = 1, size(dbl2d, dim=1) !naux dbl1d_ptr(1:nvals) => dbl2d(n, :) if (all(dbl1d_ptr == DZERO)) then @@ -259,17 +251,13 @@ subroutine package_step_ilayer(this, export_pkg, ilayer_varname, ilayer) end if end do case default - ! errmsg = 'EXPORT ilayer unsupported datatype='//trim(idt%datatype) call store_error(errmsg, .true.) end select end do - ! - ! -- synchronize file + + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) - ! - ! -- return - return end subroutine package_step_ilayer !> @brief netcdf export package dynamic input @@ -282,8 +270,7 @@ subroutine package_step(this, export_pkg) trim(this%modelname)//', package='// & trim(export_pkg%mf6_input%subcomponent_name) call store_error(errmsg, .true.) - ! - ! -- synchronize file + ! synchronize file call nf_verify(nf90_sync(this%ncid), this%nc_fname) end subroutine package_step @@ -302,18 +289,17 @@ subroutine export_layer_2d(this, export_pkg, idt, ilayer_read, ialayer, & character(len=*), intent(in) :: nc_varname character(len=*), intent(in) :: input_attr integer(I4B), optional, intent(in) :: iaux - ! -- local real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B) :: n, j, k, idxaux - ! - ! -- initialize + + ! initialize idxaux = 0 if (present(iaux)) then idxaux = iaux end if allocate (dbl2d(export_pkg%mshape(2), export_pkg%mshape(1))) - ! + if (ilayer_read) then do k = 1, size(dbl2d, dim=2) n = 0 @@ -330,14 +316,14 @@ subroutine export_layer_2d(this, export_pkg, idt, ilayer_read, ialayer, & dbl2d = DNODATA dbl2d(:, 1) = dbl1d(:) end if - ! + call nc_export_dbl2d(this%ncid, this%dim_ids, this%var_ids, this%disv, & dbl2d, nc_varname, & export_pkg%mf6_input%subcomponent_name, idt%tagname, & this%gridmap_name, idt%shape, idt%longname, input_attr, & this%deflate, this%shuffle, this%chunk_face, & export_pkg%iper, idxaux, this%nc_fname) - ! + deallocate (dbl2d) end subroutine export_layer_2d @@ -355,15 +341,15 @@ subroutine export_input_array(this, pkgtype, pkgname, mempath, idt) real(DP), dimension(:, :), pointer, contiguous :: dbl2d character(len=LINELENGTH) :: nc_varname, input_attr integer(I4B) :: iper, iaux - ! + iper = 0 iaux = 0 - ! - ! -- set package base name + + ! set package base name nc_varname = trim(pkgname)//'_'//trim(idt%mf6varname) - ! -- put input attributes + ! put input attributes input_attr = this%input_attribute(pkgname, idt) - ! + select case (idt%datatype) case ('INTEGER1D') call mem_setptr(int1d, idt%mf6varname, mempath) @@ -394,7 +380,7 @@ subroutine export_input_array(this, pkgtype, pkgname, mempath, idt) input_attr, this%deflate, this%shuffle, & this%chunk_face, iper, iaux, this%nc_fname) case default - ! -- no-op, no other datatypes exported + ! no-op, no other datatypes exported end select end subroutine export_input_array @@ -405,11 +391,11 @@ subroutine define_dim(this) use SimVariablesModule, only: isim_mode class(Mesh2dDisvExportType), intent(inout) :: this integer(I4B), dimension(:), contiguous, pointer :: ncvert - ! - ! -- set pointers to input context + + ! set pointers to input context call mem_setptr(ncvert, 'NCVERT', this%dis_mempath) - ! - ! -- time + + ! time if (isim_mode /= MVALIDATE) then call nf_verify(nf90_def_dim(this%ncid, 'time', this%totnstp, & this%dim_ids%time), this%nc_fname) @@ -427,8 +413,8 @@ subroutine define_dim(this) call nf_verify(nf90_put_att(this%ncid, this%var_ids%time, 'long_name', & 'time'), this%nc_fname) end if - ! - ! -- mesh + + ! mesh call nf_verify(nf90_def_dim(this%ncid, 'nmesh_node', this%disv%nvert, & this%dim_ids%nmesh_node), this%nc_fname) call nf_verify(nf90_def_dim(this%ncid, 'nmesh_face', this%disv%ncpl, & @@ -437,8 +423,8 @@ subroutine define_dim(this) maxval(ncvert), & this%dim_ids%max_nmesh_face_nodes), & this%nc_fname) - ! - ! -- ncpl, nlay + + ! ncpl, nlay call nf_verify(nf90_def_dim(this%ncid, 'nlay', this%disv%nlay, & this%dim_ids%nlay), this%nc_fname) end subroutine define_dim @@ -458,8 +444,8 @@ subroutine add_mesh_data(this) integer(I4B), dimension(:), allocatable :: verts real(DP), dimension(:), allocatable :: bnds integer(I4B) :: istop - ! - ! -- set pointers to input context + + ! set pointers to input context call mem_setptr(icell2d, 'ICELL2D', this%dis_mempath) call mem_setptr(ncvert, 'NCVERT', this%dis_mempath) call mem_setptr(icvert, 'ICVERT', this%dis_mempath) @@ -467,31 +453,31 @@ subroutine add_mesh_data(this) call mem_setptr(cell_y, 'YC', this%dis_mempath) call mem_setptr(vert_x, 'XV', this%dis_mempath) call mem_setptr(vert_y, 'YV', this%dis_mempath) - ! - ! -- initialize max vertices required to define cell + + ! initialize max vertices required to define cell maxvert = maxval(ncvert) - ! - ! -- set mesh container variable value to 1 + + ! set mesh container variable value to 1 call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh, 1), & this%nc_fname) - ! - ! -- allocate temporary arrays + + ! allocate temporary arrays allocate (verts(maxvert)) allocate (bnds(maxvert)) - ! - ! -- write node_x and node_y arrays to netcdf file + + ! write node_x and node_y arrays to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_node_x, & vert_x + this%disv%xorigin), this%nc_fname) call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_node_y, & vert_y + this%disv%yorigin), this%nc_fname) - ! - ! -- write face_x and face_y arrays to netcdf file + + ! write face_x and face_y arrays to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_x, & cell_x + this%disv%xorigin), this%nc_fname) call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_y, & cell_y + this%disv%yorigin), this%nc_fname) - ! - ! -- set face nodes array + + ! set face nodes array cnt = 0 do n = 1, size(ncvert) verts = NF90_FILL_INT @@ -503,41 +489,41 @@ subroutine add_mesh_data(this) iv = iv + 1 verts(iv) = icvert(m) end do - ! - ! -- write face nodes array to netcdf file + + ! write face nodes array to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_nodes, & verts, start=(/1, n/), & count=(/maxvert, 1/)), & this%nc_fname) - ! - ! -- set face y bounds array + + ! set face y bounds array bnds = NF90_FILL_DOUBLE do m = 1, size(bnds) if (verts(m) /= NF90_FILL_INT) then bnds(m) = vert_y(verts(m)) end if - ! -- write face y bounds array to netcdf file + ! write face y bounds array to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_ybnds, & bnds, start=(/1, n/), & count=(/maxvert, 1/)), & this%nc_fname) end do - ! - ! -- set face x bounds array + + ! set face x bounds array bnds = NF90_FILL_DOUBLE do m = 1, size(bnds) if (verts(m) /= NF90_FILL_INT) then bnds(m) = vert_x(verts(m)) end if - ! -- write face x bounds array to netcdf file + ! write face x bounds array to netcdf file call nf_verify(nf90_put_var(this%ncid, this%var_ids%mesh_face_xbnds, & bnds, start=(/1, n/), & count=(/maxvert, 1/)), & this%nc_fname) end do end do - ! - ! -- cleanup + + ! cleanup deallocate (bnds) deallocate (verts) end subroutine add_mesh_data @@ -564,93 +550,90 @@ subroutine nc_export_int1d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: chunk_face integer(I4B), intent(in) :: iper character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(2) :: dis_shape integer(I4B), dimension(:, :), pointer, contiguous :: int2d integer(I4B) :: axis_sz, nvals, k integer(I4B), dimension(:), allocatable :: var_id character(len=LINELENGTH) :: longname_l, varname_l - ! + if (shapestr == 'NCPL') then - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname) longname_l = export_longname(longname, pkgname, tagname, layer=0, iper=iper) - ! + allocate (var_id(1)) axis_sz = dim_ids%nmesh_face - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/axis_sz/), var_id(1)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(1), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(1), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(1), '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(1), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(1), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(1), 0, iper, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id(1), p_mem), & nc_fname) else allocate (var_id(dis%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, dis%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k, iper=iper) longname_l = export_longname(longname, pkgname, tagname, layer=k, & iper=iper) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- defalte and shuffle + ! defalte and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, iper, 0, nc_tag, nc_fname) end do - ! - ! -- reshape input + + ! reshape input dis_shape(1) = dis%ncpl dis_shape(2) = dis%nlay nvals = product(dis_shape) int2d(1:dis_shape(1), 1:dis_shape(2)) => p_mem(1:nvals) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) do k = 1, dis%nlay call nf_verify(nf90_put_var(ncid, var_id(k), int2d(:, k)), nc_fname) end do - ! - ! -- cleanup + + ! cleanup deallocate (var_id) end if end subroutine nc_export_int1d @@ -676,47 +659,45 @@ subroutine nc_export_int2d(ncid, dim_ids, var_ids, disv, p_mem, nc_varname, & integer(I4B), intent(in) :: shuffle integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(:), allocatable :: var_id character(len=LINELENGTH) :: longname_l, varname_l integer(I4B) :: k - ! + allocate (var_id(disv%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, disv%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k) longname_l = export_longname(longname, pkgname, tagname, k) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_INT, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/NF90_FILL_INT/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, 0, 0, nc_tag, nc_fname) end do - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) do k = 1, disv%nlay call nf_verify(nf90_put_var(ncid, var_id(k), p_mem(:, k)), nc_fname) end do - ! + deallocate (var_id) end subroutine nc_export_int2d @@ -741,92 +722,89 @@ subroutine nc_export_dbl1d(ncid, dim_ids, var_ids, dis, p_mem, nc_varname, & integer(I4B), intent(in) :: shuffle integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(2) :: dis_shape real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B) :: axis_sz, nvals, k integer(I4B), dimension(:), allocatable :: var_id character(len=LINELENGTH) :: longname_l, varname_l - ! + if (shapestr == 'NCPL') then - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname) longname_l = export_longname(longname, pkgname, tagname, 0) - ! + allocate (var_id(1)) axis_sz = dim_ids%nmesh_face - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/axis_sz/), var_id(1)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(1), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(1), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(1), '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(1), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(1), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(1), 0, 0, 0, nc_tag, nc_fname) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) call nf_verify(nf90_put_var(ncid, var_id(1), p_mem), & nc_fname) else allocate (var_id(dis%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, dis%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k) longname_l = export_longname(longname, pkgname, tagname, k) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/NF90_FILL_DOUBLE/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, 0, 0, nc_tag, nc_fname) end do - ! - ! -- reshape input + + ! reshape input dis_shape(1) = dis%ncpl dis_shape(2) = dis%nlay nvals = product(dis_shape) dbl2d(1:dis_shape(1), 1:dis_shape(2)) => p_mem(1:nvals) - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) do k = 1, dis%nlay call nf_verify(nf90_put_var(ncid, var_id(k), dbl2d(:, k)), nc_fname) end do - ! - ! -- cleanup + + ! cleanup deallocate (var_id) end if end subroutine nc_export_dbl1d @@ -856,54 +834,52 @@ subroutine nc_export_dbl2d(ncid, dim_ids, var_ids, disv, p_mem, nc_varname, & integer(I4B), intent(in) :: iper integer(I4B), intent(in) :: iaux character(len=*), intent(in) :: nc_fname - ! -- local integer(I4B), dimension(:), allocatable :: var_id character(len=LINELENGTH) :: longname_l, varname_l integer(I4B) :: k real(DP) :: fill_value - ! + if (iper > 0) then fill_value = DNODATA else fill_value = NF90_FILL_DOUBLE end if - ! + allocate (var_id(disv%nlay)) - ! - ! -- reenter define mode and create variable + + ! reenter define mode and create variable call nf_verify(nf90_redef(ncid), nc_fname) do k = 1, disv%nlay - ! - ! -- set names + ! set names varname_l = export_varname(nc_varname, layer=k, iper=iper, iaux=iaux) longname_l = export_longname(longname, pkgname, tagname, layer=k, iper=iper) - ! + call nf_verify(nf90_def_var(ncid, varname_l, NF90_DOUBLE, & (/dim_ids%nmesh_face/), var_id(k)), & nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters call ncvar_chunk(ncid, var_id(k), chunk_face, nc_fname) - ! -- deflate and shuffle + ! deflate and shuffle call ncvar_deflate(ncid, var_id(k), deflate, shuffle, nc_fname) - ! - ! -- put attr + + ! put attr call nf_verify(nf90_put_att(ncid, var_id(k), '_FillValue', & (/fill_value/)), nc_fname) call nf_verify(nf90_put_att(ncid, var_id(k), 'long_name', & longname_l), nc_fname) - ! - ! -- add grid mapping and mf6 attr + + ! add grid mapping and mf6 attr call ncvar_gridmap(ncid, var_id(k), gridmap_name, nc_fname) call ncvar_mf6attr(ncid, var_id(k), k, iper, iaux, nc_tag, nc_fname) end do - ! - ! -- exit define mode and write data + + ! exit define mode and write data call nf_verify(nf90_enddef(ncid), nc_fname) do k = 1, disv%nlay call nf_verify(nf90_put_var(ncid, var_id(k), p_mem(:, k)), nc_fname) end do - ! + deallocate (var_id) end subroutine nc_export_dbl2d diff --git a/src/Utilities/Export/MeshNCModel.f90 b/src/Utilities/Export/MeshNCModel.f90 index 6b28d79261c..f1f9cee0688 100644 --- a/src/Utilities/Export/MeshNCModel.f90 +++ b/src/Utilities/Export/MeshNCModel.f90 @@ -106,25 +106,25 @@ subroutine mesh_init(this, modelname, modeltype, modelfname, disenum, & integer(I4B), intent(in) :: nctype integer(I4B), intent(in) :: iout logical(LGP) :: found - ! - ! -- initialize base class + + ! initialize base class call this%NCModelExportType%init(modelname, modeltype, modelfname, disenum, & nctype, iout) - ! - ! -- allocate and initialize + + ! allocate and initialize allocate (this%chunk_face) this%chunk_face = -1 - ! - ! -- update values from input context + + ! update values from input context if (this%ncf_mempath /= '') then call mem_set_value(this%chunk_face, 'CHUNK_FACE', this%ncf_mempath, found) end if - ! + if (this%chunk_time > 0 .and. this%chunk_face > 0) then this%chunking_active = .true. end if - ! - ! -- create the netcdf file + + ! create the netcdf file call nf_verify(nf90_create(this%nc_fname, & IAND(NF90_CLOBBER, NF90_NETCDF4), this%ncid), & this%nc_fname) @@ -135,9 +135,7 @@ end subroutine mesh_init subroutine mesh_destroy(this) use MemoryManagerExtModule, only: mem_set_value class(MeshModelType), intent(inout) :: this - ! call nf_verify(nf90_close(this%ncid), this%nc_fname) - ! deallocate (this%chunk_face) nullify (this%chunk_face) end subroutine mesh_destroy @@ -146,22 +144,22 @@ end subroutine mesh_destroy !< subroutine add_global_att(this) class(MeshModelType), intent(inout) :: this - ! -- file scoped title + ! file scoped title call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'title', & this%annotation%title), this%nc_fname) - ! -- source (MODFLOW 6) + ! source (MODFLOW 6) call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'source', & this%annotation%source), this%nc_fname) - ! -- export type (MODFLOW 6) + ! export type (MODFLOW 6) call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'modflow6_grid', & this%annotation%grid), this%nc_fname) - ! -- MODFLOW 6 model type + ! MODFLOW 6 model type call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'modflow6_model', & this%annotation%model), this%nc_fname) - ! -- generation datetime + ! generation datetime call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'history', & this%annotation%history), this%nc_fname) - ! -- supported conventions + ! supported conventions call nf_verify(nf90_put_att(this%ncid, NF90_GLOBAL, 'Conventions', & this%annotation%conventions), & this%nc_fname) @@ -179,16 +177,14 @@ subroutine export_input_arrays(this, pkgtype, pkgname, mempath, param_dfns) intent(in) :: param_dfns type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iparam, isize - ! - ! -- export griddata block parameters + ! export griddata block parameters do iparam = 1, size(param_dfns) - ! -- assign param definition pointer + ! assign param definition pointer idt => param_dfns(iparam) - ! -- for now + ! for now only griddata is exported if (idt%blockname == 'GRIDDATA') then - ! -- veriy variable is allocated + ! veriy variable is allocated call get_isize(idt%mf6varname, mempath, isize) - ! if (isize > 0) then call this%export_input_array(pkgtype, pkgname, mempath, idt) end if @@ -219,31 +215,29 @@ subroutine add_pkg_data(this) integer(I4B) :: n integer(I4B), pointer :: export_arrays logical(LGP) :: found - ! + input_mempath = create_mem_path(component=this%modelname, context=idm_context) - ! - ! -- set pointers to model path package info + + ! set pointers to model path package info call mem_setptr(pkgtypes, 'PKGTYPES', input_mempath) call mem_setptr(pkgnames, 'PKGNAMES', input_mempath) call mem_setptr(mempaths, 'MEMPATHS', input_mempath) - ! + allocate (export_arrays) - ! + do n = 1, size(mempaths) - ! - ! -- initialize export_arrays + ! initialize export_arrays export_arrays = 0 - ! - ! -- set package attributes + + ! set package attributes mempath = mempaths(n) pname = pkgnames(n) ptype = pkgtypes(n) - ! - ! -- export input arrays + + ! export input arrays if (mempath /= '') then - ! -- update export + ! update export call mem_set_value(export_arrays, 'EXPORT_NC', mempath, found) - ! if (export_arrays > 0) then pkgtype = idm_subcomponent_type(this%modeltype, ptype) param_dfns => param_definitions(this%modeltype, pkgtype) @@ -251,8 +245,8 @@ subroutine add_pkg_data(this) end if end if end do - ! - ! -- cleanup + + ! cleanup deallocate (export_arrays) end subroutine add_pkg_data @@ -262,27 +256,26 @@ subroutine define_dependent(this) class(MeshModelType), intent(inout) :: this character(len=LINELENGTH) :: varname, longname integer(I4B) :: k - ! - ! -- create a dependent variable for each layer + + ! create a dependent variable for each layer do k = 1, this%nlay - ! - ! -- initialize names + ! initialize names varname = '' longname = '' - ! - ! -- set layer variable and longnames + + ! set layer variable and longnames write (varname, '(a,i0)') trim(this%xname)//'_l', k write (longname, '(a,i0,a)') trim(this%annotation%longname)// & ' (layer ', k, ')' - ! - ! -- create the netcdf dependent layer variable + + ! create the netcdf dependent layer variable call nf_verify(nf90_def_var(this%ncid, varname, NF90_DOUBLE, & (/this%dim_ids%nmesh_face, & this%dim_ids%time/), & this%var_ids%dependent(k)), & this%nc_fname) - ! - ! -- apply chunking parameters + + ! apply chunking parameters if (this%chunking_active) then call nf_verify(nf90_def_var_chunking(this%ncid, & this%var_ids%dependent(k), & @@ -291,11 +284,12 @@ subroutine define_dependent(this) this%chunk_time/)), & this%nc_fname) end if - ! -- deflate and shuffle + + ! deflate and shuffle call ncvar_deflate(this%ncid, this%var_ids%dependent(k), this%deflate, & this%shuffle, this%nc_fname) - ! - ! -- assign variable attributes + + ! assign variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%dependent(k), & 'units', 'm'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%dependent(k), & @@ -310,8 +304,8 @@ subroutine define_dependent(this) 'mesh', this%mesh_name), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%dependent(k), & 'location', 'face'), this%nc_fname) - ! - ! -- add grid mapping + + ! add grid mapping call ncvar_gridmap(this%ncid, this%var_ids%dependent(k), & this%gridmap_name, this%nc_fname) end do @@ -322,18 +316,17 @@ end subroutine define_dependent subroutine define_gridmap(this) class(MeshModelType), intent(inout) :: this integer(I4B) :: var_id - ! - ! -- was projection info provided + + ! was projection info provided if (this%ogc_wkt /= '') then - ! - ! -- create projection variable + ! create projection variable call nf_verify(nf90_redef(this%ncid), this%nc_fname) call nf_verify(nf90_def_var(this%ncid, this%gridmap_name, NF90_INT, & var_id), this%nc_fname) - ! -- cf-conventions prefers 'crs_wkt' + ! cf-conventions prefers 'crs_wkt' !call nf_verify(nf90_put_att(this%ncid, var_id, 'crs_wkt', this%ogc_wkt), & ! this%nc_fname) - ! -- QGIS recognizes 'wkt' + ! QGIS recognizes 'wkt' call nf_verify(nf90_put_att(this%ncid, var_id, 'wkt', this%ogc_wkt), & this%nc_fname) call nf_verify(nf90_enddef(this%ncid), this%nc_fname) @@ -346,12 +339,12 @@ end subroutine define_gridmap !< subroutine create_mesh(this) class(Mesh2dModelType), intent(inout) :: this - ! - ! -- create mesh container variable + + ! create mesh container variable call nf_verify(nf90_def_var(this%ncid, this%mesh_name, NF90_INT, & this%var_ids%mesh), this%nc_fname) - ! - ! -- assign container variable attributes + + ! assign container variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh, 'cf_role', & 'mesh_topology'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh, 'long_name', & @@ -370,12 +363,12 @@ subroutine create_mesh(this) 'face_node_connectivity', 'mesh_face_nodes'), & this%nc_fname) - ! -- create mesh x node (mesh vertex) variable + ! create mesh x node (mesh vertex) variable call nf_verify(nf90_def_var(this%ncid, 'mesh_node_x', NF90_DOUBLE, & (/this%dim_ids%nmesh_node/), & this%var_ids%mesh_node_x), this%nc_fname) - ! - ! -- assign mesh x node variable attributes + + ! assign mesh x node variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_x, & 'units', 'm'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_x, & @@ -383,20 +376,20 @@ subroutine create_mesh(this) this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_x, & 'long_name', 'Easting'), this%nc_fname) - ! + if (this%ogc_wkt /= '') then - ! -- associate with projection + ! associate with projection call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_x, & 'grid_mapping', this%gridmap_name), & this%nc_fname) end if - ! -- create mesh y node (mesh vertex) variable + ! create mesh y node (mesh vertex) variable call nf_verify(nf90_def_var(this%ncid, 'mesh_node_y', NF90_DOUBLE, & (/this%dim_ids%nmesh_node/), & this%var_ids%mesh_node_y), this%nc_fname) - ! - ! -- assign mesh y variable attributes + + ! assign mesh y variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_y, & 'units', 'm'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_y, & @@ -404,20 +397,20 @@ subroutine create_mesh(this) this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_y, & 'long_name', 'Northing'), this%nc_fname) - ! + if (this%ogc_wkt /= '') then - ! -- associate with projection + ! associate with projection call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_node_y, & 'grid_mapping', this%gridmap_name), & this%nc_fname) end if - ! -- create mesh x face (cell vertex) variable + ! create mesh x face (cell vertex) variable call nf_verify(nf90_def_var(this%ncid, 'mesh_face_x', NF90_DOUBLE, & (/this%dim_ids%nmesh_face/), & this%var_ids%mesh_face_x), this%nc_fname) - ! - ! -- assign mesh x face variable attributes + + ! assign mesh x face variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_x, & 'units', 'm'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_x, & @@ -428,25 +421,25 @@ subroutine create_mesh(this) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_x, 'bounds', & 'mesh_face_xbnds'), this%nc_fname) if (this%ogc_wkt /= '') then - ! -- associate with projection + ! associate with projection call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_x, & 'grid_mapping', this%gridmap_name), & this%nc_fname) end if - ! -- create mesh x cell bounds variable + ! create mesh x cell bounds variable call nf_verify(nf90_def_var(this%ncid, 'mesh_face_xbnds', NF90_DOUBLE, & (/this%dim_ids%max_nmesh_face_nodes, & this%dim_ids%nmesh_face/), & this%var_ids%mesh_face_xbnds), & this%nc_fname) - ! - ! -- create mesh y face (cell vertex) variable + + ! create mesh y face (cell vertex) variable call nf_verify(nf90_def_var(this%ncid, 'mesh_face_y', NF90_DOUBLE, & (/this%dim_ids%nmesh_face/), & this%var_ids%mesh_face_y), this%nc_fname) - ! - ! -- assign mesh y face variable attributes + + ! assign mesh y face variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_y, & 'units', 'm'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_y, & @@ -456,29 +449,29 @@ subroutine create_mesh(this) 'long_name', 'Northing'), this%nc_fname) call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_y, 'bounds', & 'mesh_face_ybnds'), this%nc_fname) - ! + if (this%ogc_wkt /= '') then - ! -- associate with projection + ! associate with projection call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_y, & 'grid_mapping', this%gridmap_name), & this%nc_fname) end if - ! -- create mesh y cell bounds variable + ! create mesh y cell bounds variable call nf_verify(nf90_def_var(this%ncid, 'mesh_face_ybnds', NF90_DOUBLE, & (/this%dim_ids%max_nmesh_face_nodes, & this%dim_ids%nmesh_face/), & this%var_ids%mesh_face_ybnds), & this%nc_fname) - ! - ! -- create mesh face nodes variable + + ! create mesh face nodes variable call nf_verify(nf90_def_var(this%ncid, 'mesh_face_nodes', NF90_INT, & (/this%dim_ids%max_nmesh_face_nodes, & this%dim_ids%nmesh_face/), & this%var_ids%mesh_face_nodes), & this%nc_fname) - ! - ! -- assign variable attributes + + ! assign variable attributes call nf_verify(nf90_put_att(this%ncid, this%var_ids%mesh_face_nodes, & 'cf_role', 'face_node_connectivity'), & this%nc_fname) @@ -500,8 +493,6 @@ subroutine ncvar_chunk(ncid, varid, chunk_face, nc_fname) integer(I4B), intent(in) :: varid integer(I4B), intent(in) :: chunk_face character(len=*), intent(in) :: nc_fname - ! - ! -- apply chunking parameters if (chunk_face > 0) then call nf_verify(nf90_def_var_chunking(ncid, varid, NF90_CHUNKED, & (/chunk_face/)), nc_fname) @@ -516,7 +507,6 @@ subroutine ncvar_deflate(ncid, varid, deflate, shuffle, nc_fname) integer(I4B), intent(in) :: deflate integer(I4B), intent(in) :: shuffle character(len=*), intent(in) :: nc_fname - ! -- deflate and shuffle if (deflate >= 0) then call nf_verify(nf90_def_var_deflate(ncid, varid, shuffle=shuffle, & deflate=1, deflate_level=deflate), & @@ -531,7 +521,6 @@ subroutine ncvar_gridmap(ncid, varid, gridmap_name, nc_fname) integer(I4B), intent(in) :: varid character(len=*), intent(in) :: gridmap_name character(len=*), intent(in) :: nc_fname - ! if (gridmap_name /= '') then call nf_verify(nf90_put_att(ncid, varid, 'coordinates', & 'mesh_face_x mesh_face_y'), nc_fname) @@ -550,7 +539,6 @@ subroutine ncvar_mf6attr(ncid, varid, layer, iper, iaux, nc_tag, nc_fname) integer(I4B), intent(in) :: iaux character(len=*), intent(in) :: nc_tag character(len=*), intent(in) :: nc_fname - ! if (nc_tag /= '') then call nf_verify(nf90_put_att(ncid, varid, 'modflow6_input', & nc_tag), nc_fname) @@ -558,12 +546,10 @@ subroutine ncvar_mf6attr(ncid, varid, layer, iper, iaux, nc_tag, nc_fname) call nf_verify(nf90_put_att(ncid, varid, 'modflow6_layer', & layer), nc_fname) end if - ! if (iper > 0) then call nf_verify(nf90_put_att(ncid, varid, 'modflow6_iper', & iper), nc_fname) end if - ! if (iaux > 0) then call nf_verify(nf90_put_att(ncid, varid, 'modflow6_iaux', & iaux), nc_fname) @@ -580,9 +566,7 @@ function export_varname(varname, layer, iper, iaux) result(vname) integer(I4B), optional, intent(in) :: iper integer(I4B), optional, intent(in) :: iaux character(len=LINELENGTH) :: vname - ! vname = '' - ! if (varname /= '') then vname = varname call lowcase(vname) diff --git a/src/Utilities/Export/ModelExport.f90 b/src/Utilities/Export/ModelExport.f90 index 74a60fb4771..49fe139e381 100644 --- a/src/Utilities/Export/ModelExport.f90 +++ b/src/Utilities/Export/ModelExport.f90 @@ -59,7 +59,6 @@ function nc_export_active() result(active) integer(I4B) :: n type(ExportModelType), pointer :: export_model active = .false. - ! do n = 1, export_models%Count() export_model => get_export_model(n) if (export_model%nctype /= NETCDF_UNDEF) then @@ -87,39 +86,38 @@ subroutine modelexports_create(iout) character(len=LINELENGTH) :: exportstr integer(I4B) :: n logical(LGP) :: found - ! + do n = 1, model_dynamic_pkgs%Count() - ! - ! -- allocate and initialize + ! allocate and initialize allocate (export_model) - ! - ! -- set pointer to dynamic input model instance + + ! set pointer to dynamic input model instance model_dynamic_input => GetDynamicModelFromList(model_dynamic_pkgs, n) - ! - ! --set input mempaths + + ! set input mempaths modelnam_mempath = & create_mem_path(component=model_dynamic_input%modelname, & subcomponent='NAM', context=idm_context) model_mempath = create_mem_path(component=model_dynamic_input%modelname, & context=idm_context) - ! -- set pointer to dis enum type + ! set pointer to dis enum type call mem_setptr(disenum, 'DISENUM', model_mempath) - ! - ! -- initialize model + + ! initialize model call export_model%init(model_dynamic_input, disenum, iout) - ! - ! -- update EXPORT_NETCDF string if provided + + ! update EXPORT_NETCDF string if provided call mem_set_value(exportstr, 'EXPORT_NETCDF', modelnam_mempath, found) if (found) then if (exportstr == 'STRUCTURED') then export_model%nctype = NETCDF_STRUCTURED else - ! -- mesh export is default + ! mesh export is default export_model%nctype = NETCDF_UGRID end if end if - ! - ! -- add model to list + + ! add model to list call add_export_model(export_model) end do end subroutine modelexports_create @@ -127,11 +125,9 @@ end subroutine modelexports_create !> @brief export model list post prepare step !! subroutine modelexports_post_prepare() - ! -- local variables class(*), pointer :: obj class(ExportModelType), pointer :: export_model integer(I4B) :: n - ! do n = 1, export_models%Count() obj => export_models%GetItem(n) if (associated(obj)) then @@ -147,11 +143,9 @@ end subroutine modelexports_post_prepare !> @brief export model list post step !! subroutine modelexports_post_step() - ! -- local variables class(*), pointer :: obj class(ExportModelType), pointer :: export_model integer(I4B) :: n - ! do n = 1, export_models%Count() obj => export_models%GetItem(n) if (associated(obj)) then @@ -167,11 +161,9 @@ end subroutine modelexports_post_step !> @brief destroy export model list !! subroutine modelexports_destroy() - ! -- local variables class(*), pointer :: obj class(ExportModelType), pointer :: export_model integer(I4B) :: n - ! do n = 1, export_models%Count() obj => export_models%GetItem(n) if (associated(obj)) then @@ -197,7 +189,6 @@ subroutine init(this, loaders, disenum, iout) type(ModelDynamicPkgsType), pointer, intent(in) :: loaders integer(I4B), intent(in) :: disenum integer(I4B), intent(in) :: iout - ! this%loaders => loaders this%modelname = loaders%modelname this%modeltype = loaders%modeltype @@ -205,7 +196,6 @@ subroutine init(this, loaders, disenum, iout) this%nctype = NETCDF_UNDEF this%disenum = disenum this%iout = iout - ! nullify (this%nc_export) end subroutine init @@ -214,7 +204,6 @@ end subroutine init !< subroutine post_prepare(this) class(ExportModelType), intent(inout) :: this - ! if (associated(this%nc_export)) then call this%nc_export%export_input() end if @@ -225,7 +214,6 @@ end subroutine post_prepare !< subroutine post_step(this) class(ExportModelType), intent(inout) :: this - ! if (associated(this%nc_export)) then call this%nc_export%step() end if @@ -236,7 +224,6 @@ end subroutine post_step !< subroutine destroy(this) class(ExportModelType), intent(inout) :: this - ! if (associated(this%nc_export)) then call this%nc_export%destroy() deallocate (this%nc_export) @@ -248,11 +235,8 @@ end subroutine destroy !! !< subroutine add_export_model(export_model) - ! -- dummy variables type(ExportModelType), pointer, intent(inout) :: export_model - ! -- local variables class(*), pointer :: obj - ! obj => export_model call export_models%Add(obj) end subroutine add_export_model @@ -261,16 +245,12 @@ end subroutine add_export_model !! !< function get_export_model(idx) result(res) - ! -- dummy variables integer(I4B), intent(in) :: idx !< package number - ! -- local variables class(ExportModelType), pointer :: res class(*), pointer :: obj - ! - ! -- initialize res + ! initialize res nullify (res) - ! - ! -- get the object from the list + ! get the object from the list obj => export_models%GetItem(idx) if (associated(obj)) then select type (obj) diff --git a/src/Utilities/Export/NCExportCreate.f90 b/src/Utilities/Export/NCExportCreate.f90 index c10c74bb3a2..a20dcf49d6f 100644 --- a/src/Utilities/Export/NCExportCreate.f90 +++ b/src/Utilities/Export/NCExportCreate.f90 @@ -39,88 +39,86 @@ subroutine create_nc_export(export_model, num_model) class(Mesh2dDisvExportType), pointer :: ugrid_disv class(DisNCStructuredType), pointer :: structured_dis class(DisBaseType), pointer :: disbase - ! + select case (export_model%disenum) case (DIS) - ! -- allocate nc structured grid export object + ! allocate nc structured grid export object if (export_model%nctype == NETCDF_UGRID) then - ! - ! -- allocate nc structured grid export object + ! allocate nc structured grid export object allocate (ugrid_dis) - ! - ! -- set dis base type + + ! set dis base type disbase => num_model%dis select type (disbase) type is (DisType) ugrid_dis%dis => disbase end select - ! - ! -- set dynamic loaders + + ! set dynamic loaders call create_export_pkglist(ugrid_dis%pkglist, export_model%loaders, & export_model%iout) - ! - ! -- initialize export object + + ! initialize export object call ugrid_dis%init(export_model%modelname, export_model%modeltype, & export_model%modelfname, export_model%disenum, & NETCDF_UGRID, export_model%iout) - ! - ! -- define export object + + ! define export object call ugrid_dis%df() - ! - ! -- set base pointer + + ! set base pointer export_model%nc_export => ugrid_dis else if (export_model%nctype == NETCDF_STRUCTURED) then - ! - ! -- allocate nc structured grid export object + ! allocate nc structured grid export object allocate (structured_dis) - ! - ! -- set dis base type + + ! set dis base type disbase => num_model%dis select type (disbase) type is (DisType) structured_dis%dis => disbase end select - ! - ! -- set dynamic loaders + + ! set dynamic loaders call create_export_pkglist(structured_dis%pkglist, export_model%loaders, & export_model%iout) - ! - ! -- initialize export object + + ! initialize export object call structured_dis%init(export_model%modelname, export_model%modeltype, & export_model%modelfname, export_model%disenum, & NETCDF_STRUCTURED, export_model%iout) - ! - ! -- define export object + + ! define export object call structured_dis%df() - ! - ! -- set base pointer + + ! set base pointer export_model%nc_export => structured_dis end if case (DISV) if (export_model%nctype == NETCDF_UGRID) then - ! -- allocate nc structured grid export object + ! allocate nc structured grid export object allocate (ugrid_disv) - ! - ! -- set dis base type + + ! set dis base type disbase => num_model%dis select type (disbase) type is (DisvType) ugrid_disv%disv => disbase end select - ! - ! -- set dynamic loaders + + ! set dynamic loaders call create_export_pkglist(ugrid_disv%pkglist, export_model%loaders, & export_model%iout) - ! - ! -- initialize export object + + ! initialize export object call ugrid_disv%init(export_model%modelname, export_model%modeltype, & export_model%modelfname, export_model%disenum, & NETCDF_UGRID, export_model%iout) - ! - ! -- define export object + + ! define export object call ugrid_disv%df() - ! - ! -- set base pointer + + ! set base pointer export_model%nc_export => ugrid_disv else errmsg = 'DISV model discretization only & @@ -155,43 +153,39 @@ subroutine create_export_pkglist(pkglist, loaders, iout) class(*), pointer :: obj logical(LGP) :: found integer(I4B) :: n - ! - ! -- create list of in scope loaders + + ! create list of in scope loaders allocate (export_arrays) - ! + do n = 1, loaders%pkglist%Count() - ! - ! -- initialize export arrays option + ! initialize export arrays option export_arrays = 0 - ! + dynamic_pkg => loaders%get(n) - ! - ! -- update export arrays option + + ! update export arrays option call mem_set_value(export_arrays, 'EXPORT_NC', & dynamic_pkg%mf6_input%mempath, found) - ! + if (export_arrays > 0 .and. dynamic_pkg%readasarrays) then select type (dynamic_pkg) type is (Mf6FileDynamicPkgLoadType) - ! rp_loader => dynamic_pkg%rp_loader - ! select type (rp_loader) type is (BoundGridInputType) - ! -- create the export object + ! create the export object allocate (export_pkg) call export_pkg%init(rp_loader%mf6_input, & rp_loader%bound_context%mshape, & rp_loader%param_names, rp_loader%nparam) obj => export_pkg call pkglist%add(obj) - ! end select end select end if end do - ! - ! -- cleanup + + ! cleanup deallocate (export_arrays) end subroutine create_export_pkglist @@ -205,24 +199,19 @@ subroutine nc_export_create() type(ExportModelType), pointer :: export_model class(NumericalModelType), pointer :: num_model integer(I4B) :: im - ! do n = 1, export_models%Count() - ! -- set pointer to export model + ! set pointer to export model export_model => get_export_model(n) if (export_model%nctype /= NETCDF_UNDEF) then - ! - ! -- netcdf export is active identify model + ! netcdf export is active identify model do im = 1, basemodellist%Count() - ! - ! -- set model pointer + ! set model pointer num_model => GetNumericalModelFromList(basemodellist, im) if (num_model%name == export_model%modelname .and. & num_model%macronym == export_model%modeltype) then - ! - ! -- allocate and initialize nc export model + ! allocate and initialize nc export model call create_nc_export(export_model, num_model) exit - ! end if end do end if diff --git a/src/Utilities/Export/NCModel.f90 b/src/Utilities/Export/NCModel.f90 index c0284f5eb79..c9e4924557b 100644 --- a/src/Utilities/Export/NCModel.f90 +++ b/src/Utilities/Export/NCModel.f90 @@ -142,7 +142,6 @@ subroutine epkg_init(this, mf6_input, mshape, param_names, & use MemoryManagerModule, only: mem_setptr use MemoryManagerExtModule, only: mem_set_value use MemoryHelperModule, only: create_mem_path - ! -- dummy class(ExportPackageType), intent(inout) :: this type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), pointer, contiguous, intent(in) :: mshape !< model shape @@ -153,29 +152,29 @@ subroutine epkg_init(this, mf6_input, mshape, param_names, & character(len=LENVARNAME) :: rs_varname character(len=LENMEMPATH) :: input_mempath integer(I4B), pointer :: rsvar - ! + this%mf6_input = mf6_input this%mshape => mshape this%nparam = nparam this%iper_export = 0 - ! + input_mempath = create_mem_path(component=mf6_input%component_name, & subcomponent=mf6_input%subcomponent_name, & context=idm_context) - ! - ! -- allocate param arrays + + ! allocate param arrays allocate (this%param_names(nparam)) allocate (this%param_reads(nparam)) - ! - ! -- set param arrays + + ! set param arrays do n = 1, nparam this%param_names(n) = param_names(n) rs_varname = rsv_name(param_names(n)) call mem_setptr(rsvar, rs_varname, mf6_input%mempath) this%param_reads(n)%invar => rsvar end do - ! - ! -- set pointer to loaded input period + + ! set pointer to loaded input period call mem_setptr(this%iper, 'IPER', mf6_input%mempath) end subroutine epkg_init @@ -183,7 +182,6 @@ end subroutine epkg_init !< subroutine epkg_destroy(this) use InputDefinitionModule, only: InputParamDefinitionType - ! -- dummy class(ExportPackageType), intent(inout) :: this if (allocated(this%param_names)) deallocate (this%param_names) end subroutine epkg_destroy @@ -199,7 +197,7 @@ subroutine set(this, modelname, modeltype, modelfname, nctype) integer(I4B), intent(in) :: nctype character(len=LINELENGTH) :: fullname integer :: values(8) - ! + this%title = '' this%model = '' this%grid = '' @@ -208,13 +206,13 @@ subroutine set(this, modelname, modeltype, modelfname, nctype) this%conventions = '' this%stdname = '' this%longname = '' - ! - ! -- set file conventions + + ! set file conventions this%conventions = 'CF-1.11' if (nctype == NETCDF_UGRID) this%conventions = & trim(this%conventions)//' UGRID-1.0' - ! - ! -- set model specific attributes + + ! set model specific attributes select case (modeltype) case ('GWF') fullname = 'Groundwater Flow' @@ -233,22 +231,22 @@ subroutine set(this, modelname, modeltype, modelfname, nctype) call store_error(errmsg) call store_error_filename(modelfname) end select - ! - ! -- set export type + + ! set export type if (nctype == NETCDF_UGRID) then this%grid = 'LAYERED MESH' else if (nctype == NETCDF_STRUCTURED) then this%grid = 'STRUCTURED' end if - ! - ! -- model description string + + ! model description string this%model = trim(modelname)//': MODFLOW 6 '//trim(fullname)// & ' ('//trim(modeltype)//') model' - ! - ! -- modflow6 version string + + ! modflow6 version string this%source = 'MODFLOW 6 '//trim(adjustl(VERSION)) - ! - ! -- create timestamp + + ! create timestamp call date_and_time(values=values) write (this%history, '(a,i0,a,i0,a,i0,a,i0,a,i0,a,i0,a,i0)') & 'first created ', values(1), '/', values(2), '/', values(3), ' ', & @@ -277,14 +275,14 @@ subroutine export_init(this, modelname, modeltype, modelfname, disenum, & character(len=LENMEMPATH) :: model_mempath type(UtlNcfParamFoundType) :: found logical(LGP) :: found_mempath - ! - ! -- allocate + + ! allocate allocate (this%deflate) allocate (this%shuffle) allocate (this%input_attr) allocate (this%chunk_time) - ! - ! -- initialize + + ! initialize this%modelname = modelname this%modeltype = modeltype this%modelfname = modelfname @@ -304,13 +302,13 @@ subroutine export_init(this, modelname, modeltype, modelfname, disenum, & this%chunk_time = -1 this%iout = iout this%chunking_active = .false. - ! + call lowcase(this%nc_fname) - ! - ! -- set file scoped attributes + + ! set file scoped attributes call this%annotation%set(modelname, modeltype, modelfname, nctype) - ! - ! -- set dependent variable basename + + ! set dependent variable basename select case (modeltype) case ('GWF') this%xname = 'head' @@ -323,8 +321,8 @@ subroutine export_init(this, modelname, modeltype, modelfname, disenum, & call store_error(errmsg) call store_error_filename(modelfname) end select - ! - ! -- set discretization input mempath + + ! set discretization input mempath if (disenum == DIS) then this%dis_mempath = create_mem_path(modelname, 'DIS', idm_context) else if (disenum == DISU) then @@ -332,15 +330,15 @@ subroutine export_init(this, modelname, modeltype, modelfname, disenum, & else if (disenum == DISV) then this%dis_mempath = create_mem_path(modelname, 'DISV', idm_context) end if - ! - ! -- set dependent variable pointer + + ! set dependent variable pointer model_mempath = create_mem_path(component=modelname) call mem_setptr(this%x, 'X', model_mempath) - ! - ! --set ncf_mempath if provided + + ! set ncf_mempath if provided call mem_set_value(this%ncf_mempath, 'NCF6_MEMPATH', this%dis_mempath, & found_mempath) - ! + if (found_mempath) then call mem_set_value(this%ogc_wkt, 'OGC_WKT', this%ncf_mempath, & found%ogc_wkt) @@ -353,17 +351,17 @@ subroutine export_init(this, modelname, modeltype, modelfname, disenum, & call mem_set_value(this%chunk_time, 'CHUNK_TIME', this%ncf_mempath, & found%chunk_time) end if - ! + if (found%ogc_wkt) then this%gridmap_name = 'projection' end if - ! - ! -- ATTR_OFF turns off modflow 6 input attributes + + ! ATTR_OFF turns off modflow 6 input attributes if (found%attr_off) then this%input_attr = 0 end if - ! - ! -- set datetime string + + ! set datetime string if (isim_mode /= MVALIDATE .and. datetime0 == '') then errmsg = 'TDIS parameter START_DATE_TIME required for NetCDF export.' call store_error(errmsg) @@ -371,8 +369,8 @@ subroutine export_init(this, modelname, modeltype, modelfname, disenum, & else this%datetime = 'days since '//trim(datetime0) end if - ! - ! -- set total nstp + + ! set total nstp this%totnstp = sum(nstp) end subroutine export_init @@ -384,7 +382,6 @@ function export_get(this, idx) result(res) integer(I4B), intent(in) :: idx class(ExportPackageType), pointer :: res class(*), pointer :: obj - ! nullify (res) obj => this%pkglist%GetItem(idx) if (associated(obj)) then @@ -405,9 +402,7 @@ function input_attribute(this, pkgname, idt) result(attr) character(len=*), intent(in) :: pkgname type(InputParamDefinitionType), pointer, intent(in) :: idt character(len=LINELENGTH) :: attr - ! attr = '' - ! if (this%input_attr > 0) then attr = trim(this%modelname)//memPathSeparator//trim(pkgname)// & memPathSeparator//trim(idt%mf6varname) @@ -425,7 +420,6 @@ function export_longname(longname, pkgname, tagname, layer, iper) result(lname) integer(I4B), optional, intent(in) :: iper character(len=LINELENGTH) :: lname character(len=LINELENGTH) :: pname, vname - ! pname = pkgname vname = tagname call lowcase(pname) @@ -454,33 +448,31 @@ subroutine export_input(this) integer(I4B) :: idx, ilayer class(ExportPackageType), pointer :: export_pkg character(len=LENVARNAME) :: ilayer_varname - ! + do idx = 1, this%pkglist%Count() - ! export_pkg => this%get(idx) - ! -- last loaded data is not current period + ! last loaded data is not current period if (export_pkg%iper /= kper) cycle - ! -- period input already exported + ! period input already exported if (export_pkg%iper_export >= export_pkg%iper) cycle - ! -- set exported iper + ! set exported iper export_pkg%iper_export = export_pkg%iper - ! - ! -- initialize ilayer + + ! initialize ilayer ilayer = 0 - ! - ! -- set expected ilayer index variable name + + ! set expected ilayer index variable name ilayer_varname = 'I'//trim(export_pkg%mf6_input%subcomponent_type(1:3)) - ! - ! -- is ilayer variable in param name list + + ! is ilayer variable in param name list ilayer = ifind(export_pkg%param_names, ilayer_varname) - ! - ! -- layer index variable is required to be first defined in period block + + ! layer index variable is required to be first defined in period block if (ilayer == 1) then call this%package_step_ilayer(export_pkg, ilayer_varname, ilayer) else call this%package_step(export_pkg) end if - ! end do end subroutine export_input @@ -490,14 +482,12 @@ subroutine export_destroy(this) use MemoryManagerExtModule, only: memorystore_remove use SimVariablesModule, only: idm_context class(NCModelExportType), intent(inout) :: this - ! - ! -- override in derived class + ! override in derived class deallocate (this%deflate) deallocate (this%shuffle) deallocate (this%input_attr) deallocate (this%chunk_time) - ! - ! -- Deallocate idm memory + ! Deallocate idm memory if (this%ncf_mempath /= '') then call memorystore_remove(this%modelname, 'NCF', idm_context) end if diff --git a/src/Utilities/Idm/BoundInputContext.f90 b/src/Utilities/Idm/BoundInputContext.f90 index bf2e42c5948..c30ed6a9e98 100644 --- a/src/Utilities/Idm/BoundInputContext.f90 +++ b/src/Utilities/Idm/BoundInputContext.f90 @@ -25,7 +25,7 @@ module BoundInputContextModule !> @brief Pointer type for read state variable !< type ReadStateVarType - integer, pointer :: invar + integer(I4B), pointer :: invar end type ReadStateVarType !> @brief derived type for boundary package input context @@ -70,75 +70,65 @@ module BoundInputContextModule !! !< subroutine create(this, mf6_input, readasarrays) - ! -- modules - ! -- dummy class(BoundInputContextType) :: this type(ModflowInputType), intent(in) :: mf6_input logical(LGP), intent(in) :: readasarrays - ! + this%mf6_input = mf6_input this%readasarrays = readasarrays - ! - ! -- create the dynamic package input context + + ! create the dynamic package input context call this%allocate_scalars() - ! - ! --return - return end subroutine create !> @brief create boundary input context !! !< subroutine allocate_scalars(this) - ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr, get_isize use MemoryManagerExtModule, only: mem_set_value - ! -- dummy class(BoundInputContextType) :: this logical(LGP) :: found - ! - ! -- set pointers to defined scalars + + ! set pointers to defined scalars call mem_setptr(this%naux, 'NAUX', this%mf6_input%mempath) - ! - ! -- allocate memory managed scalars + + ! allocate memory managed scalars call mem_allocate(this%nbound, 'NBOUND', this%mf6_input%mempath) call mem_allocate(this%ncpl, 'NCPL', this%mf6_input%mempath) - ! - ! -- internally allocate package optional scalars + + ! internally allocate package optional scalars allocate (this%maxbound) allocate (this%inamedbound) allocate (this%iprpak) - ! - ! -- initialize allocated and internal scalars + + ! initialize allocated and internal scalars this%nbound = 0 this%ncpl = 0 this%maxbound = 0 this%inamedbound = 0 this%iprpak = 0 - ! - ! -- update optional scalars + + ! update optional scalars call mem_set_value(this%inamedbound, 'BOUNDNAMES', this%mf6_input%mempath, & found) call mem_set_value(this%maxbound, 'MAXBOUND', this%mf6_input%mempath, found) call mem_set_value(this%iprpak, 'IPRPAK', this%mf6_input%mempath, found) - ! - ! -- set pointer to model shape + + ! set pointer to model shape call mem_setptr(this%mshape, 'MODEL_SHAPE', & this%mf6_input%component_mempath) - ! - ! -- update ncpl from model shape + + ! update ncpl from model shape if (size(this%mshape) == 2) then this%ncpl = this%mshape(2) else if (size(this%mshape) == 3) then this%ncpl = this%mshape(2) * this%mshape(3) end if - ! - ! -- initialize package params object + + ! initialize package params object call this%package_params%init(this%mf6_input, 'PERIOD', this%readasarrays, & this%naux, this%inamedbound) - ! - ! -- return - return end subroutine allocate_scalars !> @brief allocate_arrays @@ -147,39 +137,32 @@ end subroutine allocate_scalars !! !< subroutine allocate_arrays(this) - ! -- modules use MemoryManagerModule, only: mem_allocate, mem_setptr, get_isize use MemoryManagerExtModule, only: mem_set_value - ! -- dummy class(BoundInputContextType) :: this integer(I4B), dimension(:, :), pointer, contiguous :: cellid - ! -- local - ! - ! -- set auxname_cst and iauxmultcol + + ! set auxname_cst and iauxmultcol if (this%naux > 0) then call mem_setptr(this%auxname_cst, 'AUXILIARY', this%mf6_input%mempath) else call mem_allocate(this%auxname_cst, LENAUXNAME, 0, & 'AUXILIARY', this%mf6_input%mempath) end if - ! - ! -- allocate cellid if this is not list input + + ! allocate cellid if this is not list input if (this%readasarrays) then call mem_allocate(cellid, 0, 0, 'CELLID', this%mf6_input%mempath) end if - ! - ! -- set pointer to BOUNDNAME + + ! set pointer to BOUNDNAME call mem_setptr(this%boundname_cst, 'BOUNDNAME', this%mf6_input%mempath) - ! - ! -- set pointer to AUXVAR + + ! set pointer to AUXVAR call mem_setptr(this%auxvar, 'AUXVAR', this%mf6_input%mempath) - ! - ! -- return - return end subroutine allocate_arrays subroutine list_params_create(this, params, nparam, input_name) - ! -- modules use InputDefinitionModule, only: InputParamDefinitionType use DefinitionSelectModule, only: get_param_definition_type use DynamicPackageParamsModule, only: allocate_param_int1d, & @@ -187,36 +170,29 @@ subroutine list_params_create(this, params, nparam, input_name) allocate_param_dbl1d, & allocate_param_dbl2d, & allocate_param_charstr - ! -- dummy class(BoundInputContextType) :: this character(len=*), dimension(:), allocatable, intent(in) :: params integer(I4B), intent(in) :: nparam character(len=*), intent(in) :: input_name - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iparam - ! - ! -- + do iparam = 1, nparam idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & 'PERIOD', params(iparam), '') - ! ! allocate based on dfn datatype select case (idt%datatype) case ('INTEGER') call allocate_param_int1d(this%maxbound, idt%mf6varname, & this%mf6_input%mempath) - ! case ('DOUBLE') call allocate_param_dbl1d(this%maxbound, idt%mf6varname, & this%mf6_input%mempath) - ! case ('STRING') call allocate_param_charstr(LENBOUNDNAME, this%maxbound, idt%mf6varname, & this%mf6_input%mempath) - ! case ('INTEGER1D') if (idt%shape == 'NCELLDIM') then call allocate_param_int2d(size(this%mshape), this%maxbound, & @@ -227,7 +203,6 @@ subroutine list_params_create(this, params, nparam, input_name) call store_error(errmsg) call store_error_filename(input_name) end if - ! case ('DOUBLE1D') if (idt%shape == 'NAUX') then call allocate_param_dbl2d(this%naux, this%maxbound, & @@ -238,7 +213,6 @@ subroutine list_params_create(this, params, nparam, input_name) call store_error(errmsg) call store_error_filename(input_name) end if - ! case default errmsg = 'IDM unimplemented. BoundInputContext::list_params_create & &datatype='//trim(idt%datatype) @@ -246,9 +220,6 @@ subroutine list_params_create(this, params, nparam, input_name) call store_error_filename(input_name) end select end do - ! - ! -- return - return end subroutine list_params_create !> @brief allocate dfn array input period block parameters @@ -257,43 +228,36 @@ end subroutine list_params_create !! !< subroutine array_params_create(this, params, nparam, input_name) - ! -- modules use DefinitionSelectModule, only: get_param_definition_type use DynamicPackageParamsModule, only: allocate_param_int1d, & allocate_param_dbl1d, & allocate_param_dbl2d - ! -- dummy class(BoundInputContextType) :: this character(len=*), dimension(:), allocatable, intent(in) :: params integer(I4B), intent(in) :: nparam character(len=*), intent(in) :: input_name - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iparam - ! - ! -- allocate dfn input params + + ! allocate dfn input params do iparam = 1, nparam - ! - ! -- assign param definition pointer + + ! assign param definition pointer idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & 'PERIOD', params(iparam), '') - ! if (idt%blockname == 'PERIOD') then select case (idt%datatype) case ('INTEGER1D') call allocate_param_int1d(this%ncpl, idt%mf6varname, & this%mf6_input%mempath) - ! case ('DOUBLE1D') call allocate_param_dbl1d(this%ncpl, idt%mf6varname, & this%mf6_input%mempath) - ! case ('DOUBLE2D') call allocate_param_dbl2d(this%naux, this%ncpl, idt%mf6varname, & this%mf6_input%mempath) - ! case default errmsg = 'IDM unimplemented. BoundInputContext::array_params_create & &datatype='//trim(idt%datatype) @@ -302,28 +266,23 @@ subroutine array_params_create(this, params, nparam, input_name) end select end if end do - ! - ! -- return - return end subroutine array_params_create !> @brief destroy boundary input context !! !< subroutine destroy(this) - ! -- modules - ! -- dummy class(BoundInputContextType) :: this - ! - ! -- destroy package params object + + ! destroy package params object call this%package_params%destroy() - ! - ! -- deallocate + + ! deallocate deallocate (this%maxbound) deallocate (this%inamedbound) deallocate (this%iprpak) - ! - ! -- nullify + + ! nullify nullify (this%naux) nullify (this%nbound) nullify (this%ncpl) @@ -334,9 +293,6 @@ subroutine destroy(this) nullify (this%boundname_cst) nullify (this%auxvar) nullify (this%mshape) - ! - ! --return - return end subroutine destroy !> @brief allocate a read state variable @@ -350,31 +306,22 @@ end subroutine destroy !! !< function rsv_alloc(this, mf6varname) result(varname) - ! -- modules use ConstantsModule, only: LENVARNAME use MemoryManagerModule, only: mem_setptr, mem_allocate - ! -- dummy class(BoundInputContextType) :: this character(len=*), intent(in) :: mf6varname - ! -- local character(len=LENVARNAME) :: varname integer(I4B), pointer :: intvar - ! + varname = rsv_name(mf6varname) - ! call mem_allocate(intvar, varname, this%mf6_input%mempath) intvar = -1 - ! - ! -- return - return end function rsv_alloc !> @brief allocate and set input array to filtered param set !! !< subroutine bound_params(this, params, nparam, input_name, create) - ! -- modules - ! -- dummy class(BoundInputContextType) :: this character(len=LINELENGTH), dimension(:), allocatable, & intent(inout) :: params @@ -383,62 +330,47 @@ subroutine bound_params(this, params, nparam, input_name, create) logical(LGP), optional, intent(in) :: create logical(LGP) :: allocate_params integer(I4B) :: n - ! - ! -- initialize allocate_params + + ! initialize allocate_params allocate_params = .true. - ! - ! -- override default if provided + + ! override default if provided if (present(create)) then allocate_params = create end if - ! + if (allocated(params)) deallocate (params) - ! nparam = this%package_params%nparam - ! allocate (params(nparam)) - ! do n = 1, nparam params(n) = this%package_params%params(n) end do - ! + if (allocate_params) then if (this%readasarrays) then - ! call this%array_params_create(params, nparam, input_name) else - ! call this%list_params_create(params, nparam, input_name) end if end if - ! - ! -- return - return end subroutine bound_params !> @brief create read state variable name !! !< function rsv_name(mf6varname) result(varname) - ! -- modules use ConstantsModule, only: LENVARNAME - ! -- dummy character(len=*), intent(in) :: mf6varname - ! -- local character(len=LENVARNAME) :: varname integer(I4B) :: ilen character(len=2) :: prefix = 'IN' - ! + ilen = len_trim(mf6varname) - ! if (ilen > (LENVARNAME - len(prefix))) then varname = prefix//mf6varname(1:(LENVARNAME - len(prefix))) else varname = prefix//trim(mf6varname) end if - ! - ! -- return - return end function rsv_name end module BoundInputContextModule diff --git a/src/Utilities/Idm/DefinitionSelect.f90 b/src/Utilities/Idm/DefinitionSelect.f90 index b65e62801a9..07753b408dd 100644 --- a/src/Utilities/Idm/DefinitionSelect.f90 +++ b/src/Utilities/Idm/DefinitionSelect.f90 @@ -26,43 +26,39 @@ module DefinitionSelectModule !> @brief allocate and set RECARRAY, KEYSTRING or RECORD param list !< subroutine idt_parse_rectype(idt, cols, ncol) - ! -- modules use ConstantsModule, only: LINELENGTH use InputOutputModule, only: parseline - ! -- dummy type(InputParamDefinitionType), pointer, intent(in) :: idt character(len=LINELENGTH), dimension(:), allocatable, & intent(inout) :: cols integer(I4B), intent(inout) :: ncol - ! -- local character(len=:), allocatable :: parse_str character(len=LINELENGTH), dimension(:), allocatable :: param_cols integer(I4B) :: param_ncol, n - ! - ! -- initialize + + ! initialize if (allocated(cols)) deallocate (cols) ncol = 0 - ! - ! -- split definition + + ! split definition parse_str = trim(idt%datatype)//' ' call parseline(parse_str, param_ncol, param_cols) - ! + if (param_ncol > 1) then if (param_cols(1) == 'RECARRAY' .or. & param_cols(1) == 'KEYSTRING' .or. & param_cols(1) == 'RECORD') then - ! -- exclude 1st column + ! exclude 1st column allocate (cols(param_ncol - 1)) do n = 2, param_ncol cols(n - 1) = param_cols(n) end do - ! - ! -- set ncol + ! set ncol ncol = param_ncol - 1 end if end if - ! - ! -- cleanup + + ! cleanup if (allocated(param_cols)) deallocate (param_cols) if (allocated(parse_str)) deallocate (parse_str) end subroutine idt_parse_rectype @@ -70,13 +66,9 @@ end subroutine idt_parse_rectype !> @brief return input definition type datatype !< function idt_datatype(idt) result(datatype) - ! -- modules use ConstantsModule, only: LINELENGTH - ! -- dummy type(InputParamDefinitionType), pointer, intent(in) :: idt - ! -- result character(len=LINELENGTH) :: datatype - ! if (idt%datatype(1:9) == 'KEYSTRING') then datatype = 'KEYSTRING' else if (idt%datatype(1:8) == 'RECARRAY') then @@ -104,7 +96,7 @@ function get_param_definition_type(input_definition_types, & type(InputParamDefinitionType), pointer :: idt !< corresponding InputParameterDefinitionType for this tag type(InputParamDefinitionType), pointer :: tmp_ptr integer(I4B) :: i - ! + nullify (idt) do i = 1, size(input_definition_types) tmp_ptr => input_definition_types(i) @@ -116,7 +108,7 @@ function get_param_definition_type(input_definition_types, & exit end if end do - ! + if (.not. associated(idt)) then write (errmsg, '(a,a,a,a,a)') & 'Input file tag not found: "', trim(tagname), & @@ -139,7 +131,7 @@ function get_aggregate_definition_type(input_definition_types, component_type, & type(InputParamDefinitionType), pointer :: idt !< corresponding InputParameterDefinitionType for this block type(InputParamDefinitionType), pointer :: tmp_ptr integer(I4B) :: i - ! + nullify (idt) do i = 1, size(input_definition_types) tmp_ptr => input_definition_types(i) @@ -150,7 +142,7 @@ function get_aggregate_definition_type(input_definition_types, component_type, & exit end if end do - ! + if (.not. associated(idt)) then write (errmsg, '(a,a,a,a,a,a,a)') & 'Idm aggregate definition not found: ', trim(blockname), & @@ -178,42 +170,41 @@ subroutine split_record_definition(input_definition_types, component_type, & type(InputParamDefinitionType), pointer :: tmp_ptr integer(I4B) :: i character(len=:), allocatable :: parse_str - ! - ! -- initialize to deallocated + + ! initialize to deallocated if (allocated(words)) deallocate (words) - ! - ! -- return all tokens of multi-record type that matches the first - ! -- tag following the expected first token "RECORD" + + ! return all tokens of multi-record type that matches the first + ! tag following the expected first token "RECORD" do i = 1, size(input_definition_types) - ! - ! -- initialize + + ! initialize nwords = 0 - ! - ! -- set ptr to current definition + + ! set ptr to current definition tmp_ptr => input_definition_types(i) - ! - ! -- match for definition to split + + ! match for definition to split if (tmp_ptr%component_type == component_type .and. & tmp_ptr%subcomponent_type == subcomponent_type .and. & idt_datatype(tmp_ptr) == 'RECORD') then - ! - ! -- set split string + + ! set split string parse_str = trim(input_definition_types(i)%datatype)//' ' - ! - ! -- split + + ! split call parseline(parse_str, nwords, words) - ! - ! -- check for match and manage memory + + ! check for match and manage memory if (nwords >= 2) then if (words(1) == 'RECORD' .and. words(2) == tagname) then exit end if end if - ! - ! -- deallocate + + ! deallocate if (allocated(parse_str)) deallocate (parse_str) if (allocated(words)) deallocate (words) - ! end if end do end subroutine split_record_definition diff --git a/src/Utilities/Idm/DynamicPackageParams.f90 b/src/Utilities/Idm/DynamicPackageParams.f90 index b9aecc291a4..a1b92511e90 100644 --- a/src/Utilities/Idm/DynamicPackageParams.f90 +++ b/src/Utilities/Idm/DynamicPackageParams.f90 @@ -50,24 +50,20 @@ module DynamicPackageParamsModule !< subroutine init(this, mf6_input, blockname, readasarrays, iauxiliary, & inamedbound) - ! -- modules - ! -- dummy class(DynamicPackageParamsType) :: this type(ModflowInputType), intent(in) :: mf6_input character(len=*) :: blockname logical(LGP), intent(in) :: readasarrays integer(I4B), intent(in) :: iauxiliary integer(I4B), intent(in) :: inamedbound - !integer(I4B) :: iparam - ! -- local - ! + this%mf6_input = mf6_input this%blockname = blockname this%nparam = 0 this%iauxiliary = iauxiliary this%inamedbound = inamedbound - ! - ! -- determine in scope input params + + ! determine in scope input params if (readasarrays) then call this%set_filtered_grid() else @@ -79,11 +75,7 @@ end subroutine init !! !< subroutine destroy(this) - ! -- modules - ! -- dummy class(DynamicPackageParamsType) :: this - ! - ! -- deallocate if (allocated(this%params)) deallocate (this%params) end subroutine destroy @@ -91,32 +83,28 @@ end subroutine destroy !! !< subroutine set_filtered_grid(this) - ! -- modules - ! -- dummy class(DynamicPackageParamsType) :: this - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B), dimension(:), allocatable :: idt_idxs type(CharacterStringType), dimension(:), pointer, contiguous :: boundname real(DP), dimension(:, :), pointer, contiguous :: auxvar integer(I4B) :: keepcnt, iparam logical(LGP) :: keep - ! - ! -- initialize + + ! initialize keepcnt = 0 - ! - ! -- allocate dfn input params + + ! allocate dfn input params do iparam = 1, size(this%mf6_input%param_dfns) - ! keep = .true. - ! - ! -- assign param definition pointer + + ! assign param definition pointer idt => this%mf6_input%param_dfns(iparam) - ! + if (idt%blockname /= this%blockname) then keep = .false. end if - ! + if (idt%tagname == 'AUX') then if (this%iauxiliary == 0) then keep = .false. @@ -127,27 +115,27 @@ subroutine set_filtered_grid(this) this%mf6_input%mempath) end if end if - ! + if (keep) then keepcnt = keepcnt + 1 call expandarray(idt_idxs) idt_idxs(keepcnt) = iparam end if end do - ! - ! -- update nparam + + ! update nparam this%nparam = keepcnt - ! - ! -- allocate filtcols + + ! allocate filtcols allocate (this%params(this%nparam)) - ! - ! -- set filtcols + + ! set filtcols do iparam = 1, this%nparam idt => this%mf6_input%param_dfns(idt_idxs(iparam)) this%params(iparam) = trim(idt%tagname) end do - ! - ! -- cleanup + + ! cleanup deallocate (idt_idxs) end subroutine set_filtered_grid @@ -157,41 +145,35 @@ end subroutine set_filtered_grid !! to determine which columns are to be read in this run. !< subroutine set_filtered_list(this) - ! -- modules - ! -- dummy class(DynamicPackageParamsType) :: this - ! -- local type(InputParamDefinitionType), pointer :: ra_idt, idt character(len=LINELENGTH), dimension(:), allocatable :: ra_cols type(CharacterStringType), dimension(:), pointer, contiguous :: boundname real(DP), dimension(:, :), pointer, contiguous :: auxvar integer(I4B) :: ra_ncol, icol, keepcnt logical(LGP) :: keep - ! - ! -- initialize + + ! initialize keepcnt = 0 - ! - ! -- get aggregate param definition for period block + + ! get aggregate param definition for period block ra_idt => & get_aggregate_definition_type(this%mf6_input%aggregate_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & this%blockname) - ! - ! -- split recarray definition + ! split recarray definition call idt_parse_rectype(ra_idt, ra_cols, ra_ncol) - ! - ! -- determine which columns are in scope + + ! determine which columns are in scope do icol = 1, ra_ncol - ! keep = .false. - ! - ! -- set dfn pointer to recarray parameter + + ! set dfn pointer to recarray parameter idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & this%blockname, ra_cols(icol), '') - ! if (ra_cols(icol) == 'RECARRAY') then ! no-op else if (ra_cols(icol) == 'AUX') then @@ -208,21 +190,21 @@ subroutine set_filtered_list(this) this%mf6_input%mempath) end if else - ! -- determine if the param is scope + ! determine if the param is scope keep = pkg_param_in_scope(this%mf6_input, this%blockname, ra_cols(icol)) end if - ! + if (keep) then keepcnt = keepcnt + 1 call expandarray(this%params) this%params(keepcnt) = trim(ra_cols(icol)) end if end do - ! - ! -- update nparam + + ! update nparam this%nparam = keepcnt - ! - ! -- cleanup + + ! cleanup deallocate (ra_cols) end subroutine set_filtered_list @@ -230,20 +212,14 @@ end subroutine set_filtered_list !! !< subroutine package_params(this, params, nparam) - ! -- modules - ! -- dummy class(DynamicPackageParamsType) :: this character(len=LINELENGTH), dimension(:), allocatable, & intent(inout) :: params integer(I4B), intent(inout) :: nparam integer(I4B) :: n - ! if (allocated(params)) deallocate (params) - ! nparam = this%nparam - ! allocate (params(nparam)) - ! do n = 1, nparam params(n) = this%params(n) end do @@ -259,7 +235,6 @@ subroutine allocate_param_charstr(strlen, nrow, varname, mempath) type(CharacterStringType), dimension(:), pointer, & contiguous :: charstr1d integer(I4B) :: n - ! call mem_allocate(charstr1d, strlen, nrow, varname, mempath) do n = 1, nrow charstr1d(n) = '' @@ -274,7 +249,6 @@ subroutine allocate_param_int1d(nrow, varname, mempath) character(len=*), intent(in) :: mempath !< variable mempath integer(I4B), dimension(:), pointer, contiguous :: int1d integer(I4B) :: n - ! call mem_allocate(int1d, nrow, varname, mempath) do n = 1, nrow int1d(n) = IZERO @@ -290,7 +264,6 @@ subroutine allocate_param_int2d(ncol, nrow, varname, mempath) character(len=*), intent(in) :: mempath !< variable mempath integer(I4B), dimension(:, :), pointer, contiguous :: int2d integer(I4B) :: n, m - ! call mem_allocate(int2d, ncol, nrow, varname, mempath) do m = 1, nrow do n = 1, ncol @@ -307,7 +280,6 @@ subroutine allocate_param_dbl1d(nrow, varname, mempath) character(len=*), intent(in) :: mempath !< variable mempath real(DP), dimension(:), pointer, contiguous :: dbl1d integer(I4B) :: n - ! call mem_allocate(dbl1d, nrow, varname, mempath) do n = 1, nrow dbl1d(n) = DZERO @@ -323,7 +295,6 @@ subroutine allocate_param_dbl2d(ncol, nrow, varname, mempath) character(len=*), intent(in) :: mempath !< variable mempath real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B) :: n, m - ! call mem_allocate(dbl2d, ncol, nrow, varname, mempath) do m = 1, nrow do n = 1, ncol @@ -336,36 +307,29 @@ end subroutine allocate_param_dbl2d !! !< function pkg_param_in_scope(mf6_input, blockname, tagname) result(in_scope) - ! -- modules use MemoryManagerModule, only: get_isize, mem_setptr - ! -- dummy type(ModflowInputType), intent(in) :: mf6_input character(len=*), intent(in) :: blockname character(len=*), intent(in) :: tagname - ! -- return logical(LGP) :: in_scope - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B) :: pdim_isize, popt_isize integer(I4B), pointer :: pdim - ! - ! -- initialize + + ! initialize in_scope = .false. - ! + idt => get_param_definition_type(mf6_input%param_dfns, & mf6_input%component_type, & mf6_input%subcomponent_type, & blockname, tagname, '') - ! if (idt%required) then - ! -- required params always included + ! required params always included in_scope = .true. else - ! - ! -- package specific logic to determine if input params to be read + ! package specific logic to determine if input params to be read select case (mf6_input%subcomponent_type) case ('EVT') - ! if (tagname == 'PXDP' .or. tagname == 'PETM') then call get_isize('NSEG', mf6_input%mempath, pdim_isize) if (pdim_isize > 0) then @@ -380,7 +344,6 @@ function pkg_param_in_scope(mf6_input, blockname, tagname) result(in_scope) in_scope = .true. end if end if - ! case ('NAM') in_scope = .true. case default diff --git a/src/Utilities/Idm/IdmLoad.f90 b/src/Utilities/Idm/IdmLoad.f90 index 4824a47d3d8..8ce548c8f1b 100644 --- a/src/Utilities/Idm/IdmLoad.f90 +++ b/src/Utilities/Idm/IdmLoad.f90 @@ -38,14 +38,10 @@ subroutine idm_df() use InputLoadTypeModule, only: GetDynamicModelFromList class(ModelDynamicPkgsType), pointer :: model_dynamic_input integer(I4B) :: n - ! do n = 1, model_dynamic_pkgs%Count() model_dynamic_input => GetDynamicModelFromList(model_dynamic_pkgs, n) call model_dynamic_input%df() end do - ! - ! -- return - return end subroutine idm_df !> @brief load package dynamic data for period @@ -54,14 +50,10 @@ subroutine idm_rp() use InputLoadTypeModule, only: GetDynamicModelFromList class(ModelDynamicPkgsType), pointer :: model_dynamic_input integer(I4B) :: n - ! do n = 1, model_dynamic_pkgs%Count() model_dynamic_input => GetDynamicModelFromList(model_dynamic_pkgs, n) call model_dynamic_input%rp() end do - ! - ! -- return - return end subroutine idm_rp !> @brief advance package dynamic data for period steps @@ -70,14 +62,10 @@ subroutine idm_ad() use InputLoadTypeModule, only: GetDynamicModelFromList class(ModelDynamicPkgsType), pointer :: model_dynamic_input integer(I4B) :: n - ! do n = 1, model_dynamic_pkgs%Count() model_dynamic_input => GetDynamicModelFromList(model_dynamic_pkgs, n) call model_dynamic_input%ad() end do - ! - ! -- return - return end subroutine idm_ad !> @brief idm deallocate routine @@ -94,11 +82,11 @@ subroutine idm_da(iout) character(len=LENCOMPONENTNAME) :: exg_comp, exg_subcomp character(len=LENMEMPATH) :: input_mempath, mempath integer(I4B) :: n - ! - ! -- deallocate dynamic loaders + + ! deallocate dynamic loaders call dynamic_da(iout) - ! - ! -- deallocate EXG mempaths + + ! deallocate EXG mempaths input_mempath = create_mem_path('SIM', 'NAM', idm_context) call mem_setptr(mempaths, 'EXGMEMPATHS', input_mempath) do n = 1, size(mempaths) @@ -108,15 +96,12 @@ subroutine idm_da(iout) call memorystore_remove(exg_comp, exg_subcomp, idm_context) end if end do - ! - ! -- deallocate input context SIM paths + + ! deallocate input context SIM paths call memorystore_remove('UTL', 'HPC', idm_context) call memorystore_remove('SIM', 'TDIS', idm_context) call memorystore_remove('SIM', 'NAM', idm_context) call memorystore_remove(component='SIM', context=idm_context) - ! - ! -- return - return end subroutine idm_da !> @brief load an integrated model package from supported source @@ -140,35 +125,31 @@ recursive subroutine input_load(component_type, subcomponent_type, modelname, & class(DynamicPkgLoadBaseType), pointer :: dynamic_loader class(ModelDynamicPkgsType), pointer :: dynamic_pkgs integer(I4B) :: n - ! - ! -- create model package loader + + ! create model package loader static_loader => & create_input_loader(component_type, subcomponent_type, modelname, pkgname, & pkgtype, filename, modelfname, nc_vars) - ! - ! -- load static input and set dynamic loader + + ! load static input and set dynamic loader dynamic_loader => static_loader%load(iout) - ! + if (associated(dynamic_loader)) then - ! - ! -- set pointer to model dynamic packages list + ! set pointer to model dynamic packages list dynamic_pkgs => & dynamic_model_pkgs(static_loader%mf6_input%component_type, modelname, & static_loader%component_input_name, nc_vars%nc_fname, & nc_vars%ncid, iout) - ! - ! -- add dynamic pkg loader to list + ! add dynamic pkg loader to list call dynamic_pkgs%add(dynamic_loader) - ! end if - ! - ! -- create subpackage list + + ! create subpackage list call static_loader%create_subpkg_list() - ! - ! -- load idm integrated subpackages + + ! load idm integrated subpackages do n = 1, static_loader%subpkg_list%pnum - ! - ! -- load subpackage + ! load subpackage call input_load(static_loader%subpkg_list%component_types(n), & static_loader%subpkg_list%subcomponent_types(n), & static_loader%mf6_input%component_name, & @@ -177,13 +158,10 @@ recursive subroutine input_load(component_type, subcomponent_type, modelname, & static_loader%subpkg_list%filenames(n), & modelfname, nc_vars, iout) end do - ! - ! -- cleanup + + ! cleanup call static_loader%destroy() deallocate (static_loader) - ! - ! -- return - return end subroutine input_load !> @brief load integrated model package files @@ -197,23 +175,19 @@ subroutine load_model_pkgs(model_pkg_inputs, iout) integer(i4B), intent(in) :: iout type(NCFileVarsType), pointer :: nc_vars integer(I4B) :: itype, ipkg - ! + nc_vars => netcdf_context(model_pkg_inputs%modeltype, & model_pkg_inputs%component_type, & model_pkg_inputs%modelname, & model_pkg_inputs%modelfname, iout) - ! - ! -- load package instances by type + ! load package instances by type do itype = 1, size(model_pkg_inputs%pkglist) - ! - ! -- load package instances + ! load package instances do ipkg = 1, model_pkg_inputs%pkglist(itype)%pnum - if (idm_integrated(model_pkg_inputs%component_type, & model_pkg_inputs%pkglist(itype)%subcomponent_type)) & then - ! - ! -- only load if model pkg can read from input context + ! only load if model pkg can read from input context call input_load(model_pkg_inputs%component_type, & model_pkg_inputs%pkglist(itype)%subcomponent_type, & model_pkg_inputs%modelname, & @@ -222,8 +196,7 @@ subroutine load_model_pkgs(model_pkg_inputs, iout) model_pkg_inputs%pkglist(itype)%filenames(ipkg), & model_pkg_inputs%modelfname, nc_vars, iout) else - ! - ! -- open input file for package parser + ! open input file for package parser model_pkg_inputs%pkglist(itype)%inunits(ipkg) = & open_source_file(model_pkg_inputs%pkglist(itype)%pkgtype, & model_pkg_inputs%pkglist(itype)%filenames(ipkg), & @@ -231,20 +204,16 @@ subroutine load_model_pkgs(model_pkg_inputs, iout) end if end do end do - ! - ! -- cleanup + + ! cleanup call nc_vars%destroy() deallocate (nc_vars) nullify (nc_vars) - ! - ! -- return - return end subroutine load_model_pkgs !> @brief load model namfiles and model package files !< subroutine load_models(iout) - ! -- modules use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr use CharacterStringModule, only: CharacterStringType @@ -253,9 +222,7 @@ subroutine load_models(iout) use ModelPackageInputsModule, only: ModelPackageInputsType use SourceCommonModule, only: idm_component_type, inlen_check use SourceLoadModule, only: load_modelnam - ! -- dummy integer(I4B), intent(in) :: iout - ! -- local type(DistributedSimType), pointer :: ds integer(I4B), dimension(:), pointer :: model_loadmask character(len=LENMEMPATH) :: input_mempath @@ -269,61 +236,51 @@ subroutine load_models(iout) character(len=LENMODELNAME) :: mname type(ModelPackageInputsType), allocatable :: model_pkg_inputs integer(I4B) :: n - ! - ! -- get model mask + + ! get model mask ds => get_dsim() model_loadmask => ds%get_load_mask() - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context model attribute arrays + + ! set pointers to input context model attribute arrays call mem_setptr(mtypes, 'MTYPE', input_mempath) call mem_setptr(mfnames, 'MFNAME', input_mempath) call mem_setptr(mnames, 'MNAME', input_mempath) - ! + do n = 1, size(mtypes) - ! - ! -- attributes for this model + ! attributes for this model mtype = mtypes(n) mfname = mfnames(n) call inlen_check(mnames(n), mname, LENMODELNAME, 'MODELNAME') - ! - ! -- terminate if errors were detected + + ! terminate if errors were detected if (count_errors() > 0) then call store_error_filename(simfile) end if - ! - ! -- load specified model inputs + + ! load specified model inputs if (model_loadmask(n) > 0) then - ! - ! -- load model nam file + ! load model nam file call load_modelnam(mtype, mfname, mname, iout) - ! - ! -- create description of model packages + ! create description of model packages allocate (model_pkg_inputs) call model_pkg_inputs%init(mtype, mfname, mname, iout) - ! - ! -- load packages + ! load packages call load_model_pkgs(model_pkg_inputs, iout) - ! - ! -- publish pkg info to input context + ! publish pkg info to input context call model_pkg_inputs%memload() - ! - ! -- cleanup + ! cleanup call model_pkg_inputs%destroy() deallocate (model_pkg_inputs) end if end do - ! - ! -- return - return end subroutine load_models !> @brief load exchange files !< subroutine load_exchanges(iout) - ! -- modules use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr, mem_allocate, & mem_deallocate, get_isize @@ -333,9 +290,7 @@ subroutine load_exchanges(iout) use SourceCommonModule, only: idm_subcomponent_type, ifind_charstr, & inlen_check use SourceLoadModule, only: create_input_loader, remote_model_ndim - ! -- dummy integer(I4B), intent(in) :: iout - ! -- local type(DistributedSimType), pointer :: ds integer(I4B), dimension(:), pointer :: model_loadmask type(CharacterStringType), dimension(:), contiguous, & @@ -362,15 +317,15 @@ subroutine load_exchanges(iout) class(StaticPkgLoadBaseType), pointer :: static_loader class(DynamicPkgLoadBaseType), pointer :: dynamic_loader integer(I4B) :: n, m1_idx, m2_idx, irem, isize - ! - ! -- get model mask + + ! get model mask ds => get_dsim() model_loadmask => ds%get_load_mask() - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context exg and model attribute arrays + + ! set pointers to input context exg and model attribute arrays call mem_setptr(etypes, 'EXGTYPE', input_mempath) call mem_setptr(efiles, 'EXGFILE', input_mempath) call mem_setptr(emnames_a, 'EXGMNAMEA', input_mempath) @@ -378,51 +333,49 @@ subroutine load_exchanges(iout) call mem_setptr(mtypes, 'MTYPE', input_mempath) call mem_setptr(mfnames, 'MFNAME', input_mempath) call mem_setptr(mnames, 'MNAME', input_mempath) - ! - ! -- allocate mempaths array for exchanges + + ! allocate mempaths array for exchanges call mem_allocate(emempaths, LENMEMPATH, size(etypes), 'EXGMEMPATHS', & input_mempath) - ! - ! -- load exchanges for local models + + ! load exchanges for local models do n = 1, size(etypes) - ! - ! -- attributes for this exchange + ! attributes for this exchange exgtype = etypes(n) efname = efiles(n) call inlen_check(emnames_a(n), mname1, LENMODELNAME, 'MODELNAME') call inlen_check(emnames_b(n), mname2, LENMODELNAME, 'MODELNAME') - ! + ! initialize mempath as no path emempaths(n) = '' irem = 0 - ! - ! -- set indexes for exchange model names + + ! set indexes for exchange model names m1_idx = ifind_charstr(mnames, mname1) m2_idx = ifind_charstr(mnames, mname2) - ! + if (m1_idx <= 0 .or. m2_idx <= 0) then errmsg = 'Exchange has invalid (unrecognized) model name(s):' if (m1_idx <= 0) errmsg = trim(errmsg)//' '//trim(mname1) if (m2_idx <= 0) errmsg = trim(errmsg)//' '//trim(mname2) call store_error(errmsg) end if - ! - ! -- terminate if errors were detected + + ! terminate if errors were detected if (count_errors() > 0) then call store_error_filename(simfile) end if - ! - ! -- load the exchange input if either model local + + ! load the exchange input if either model local if (model_loadmask(m1_idx) > 0 .or. model_loadmask(m2_idx) > 0) then - ! - ! -- set index if either model is remote + ! set index if either model is remote if (model_loadmask(m1_idx) == 0) then irem = m1_idx else if (model_loadmask(m2_idx) == 0) then irem = m2_idx end if - ! - ! -- allocate and set remote model NCELLDIM + + ! allocate and set remote model NCELLDIM if (irem > 0) then mtype = mtypes(irem) mfname = mfnames(irem) @@ -438,25 +391,25 @@ subroutine load_exchanges(iout) else nullify (ncelldim) end if - ! - ! -- set subcomponent strings + + ! set subcomponent strings sc_type = trim(idm_subcomponent_type('EXG', exgtype)) write (sc_name, '(a,i0)') trim(sc_type)//'_', n - ! - ! -- create and set exchange mempath + + ! create and set exchange mempath mempath = create_mem_path('EXG', sc_name, idm_context) emempaths(n) = mempath - ! - ! -- allocate and set exgid + + ! allocate and set exgid call mem_allocate(exgid, 'EXGID', mempath) exgid = n - ! - ! -- create exchange loader + + ! create exchange loader static_loader => create_input_loader('EXG', sc_type, 'EXG', sc_name, & exgtype, efname, simfile) - ! -- load static input + ! load static input dynamic_loader => static_loader%load(iout) - ! + if (associated(dynamic_loader)) then errmsg = 'IDM unimplemented. Dynamic Exchanges not supported.' call store_error(errmsg) @@ -465,12 +418,10 @@ subroutine load_exchanges(iout) call static_loader%destroy() deallocate (static_loader) end if - ! end if - ! end do - ! - ! -- clean up temporary NCELLDIM for remote models + + ! clean up temporary NCELLDIM for remote models do n = 1, size(mnames) if (model_loadmask(n) == 0) then mname = mnames(n) @@ -482,9 +433,6 @@ subroutine load_exchanges(iout) end if end if end do - ! - ! -- return - return end subroutine load_exchanges !> @brief MODFLOW 6 mfsim.nam input load routine @@ -492,33 +440,22 @@ end subroutine load_exchanges subroutine simnam_load(paramlog) use SourceLoadModule, only: load_simnam integer(I4B), intent(inout) :: paramlog - ! - ! -- load sim nam file + ! load sim nam file call load_simnam() - ! - ! -- allocate any unallocated simnam params + ! allocate any unallocated simnam params call simnam_allocate() - ! - ! -- read and set input parameter logging keyword + ! read and set input parameter logging keyword paramlog = input_param_log() - ! - ! -- memload summary info + ! memload summary info call simnam_load_dim() - ! - ! --return - return end subroutine simnam_load !> @brief MODFLOW 6 tdis input load routine !< subroutine simtdis_load() use SourceLoadModule, only: load_simtdis - ! - ! -- load sim tdis file + ! load sim tdis file call load_simtdis() - ! - ! --return - return end subroutine simtdis_load !> @brief retrieve list of model dynamic loaders @@ -535,11 +472,11 @@ function dynamic_model_pkgs(modeltype, modelname, modelfname, nc_fname, & class(ModelDynamicPkgsType), pointer :: model_dynamic_input class(ModelDynamicPkgsType), pointer :: temp integer(I4B) :: id - ! - ! -- initialize + + ! initialize nullify (model_dynamic_input) - ! - ! -- assign model loader object if found + + ! assign model loader object if found do id = 1, model_dynamic_pkgs%Count() temp => GetDynamicModelFromList(model_dynamic_pkgs, id) if (temp%modelname == modelname) then @@ -547,17 +484,14 @@ function dynamic_model_pkgs(modeltype, modelname, modelfname, nc_fname, & exit end if end do - ! - ! -- create if not found + + ! create if not found if (.not. associated(model_dynamic_input)) then allocate (model_dynamic_input) call model_dynamic_input%init(modeltype, modelname, modelfname, & nc_fname, ncid, iout) call AddDynamicModelToList(model_dynamic_pkgs, model_dynamic_input) end if - ! - ! -- return - return end function dynamic_model_pkgs !> @brief deallocate all model dynamic loader collections @@ -568,7 +502,6 @@ subroutine dynamic_da(iout) integer(I4B), intent(in) :: iout class(ModelDynamicPkgsType), pointer :: model_dynamic_input integer(I4B) :: n - ! do n = 1, model_dynamic_pkgs%Count() model_dynamic_input => GetDynamicModelFromList(model_dynamic_pkgs, n) call nc_close(model_dynamic_input%ncid, model_dynamic_input%nc_fname) @@ -576,11 +509,7 @@ subroutine dynamic_da(iout) deallocate (model_dynamic_input) nullify (model_dynamic_input) end do - ! call model_dynamic_pkgs%Clear() - ! - ! -- return - return end subroutine dynamic_da !> @brief return sim input context PRINT_INPUT value @@ -592,14 +521,10 @@ function input_param_log() result(paramlog) character(len=LENMEMPATH) :: simnam_mempath integer(I4B) :: paramlog integer(I4B), pointer :: p - ! - ! -- read and set input value of PRINT_INPUT + ! read and set input value of PRINT_INPUT simnam_mempath = create_mem_path('SIM', 'NAM', idm_context) call mem_setptr(p, 'PRINT_INPUT', simnam_mempath) paramlog = p - ! - ! -- return - return end function input_param_log !> @brief load simulation summary info to input context @@ -616,29 +541,26 @@ subroutine simnam_load_dim() pointer :: etypes !< model types integer(I4B), pointer :: nummodels integer(I4B), pointer :: numexchanges - ! - ! -- initialize + + ! initialize nullify (nummodels) nullify (numexchanges) - ! - ! -- set memory paths + + ! set memory paths sim_mempath = create_mem_path(component='SIM', context=idm_context) simnam_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to loaded simnam arrays + + ! set pointers to loaded simnam arrays call mem_setptr(mtypes, 'MTYPE', simnam_mempath) call mem_setptr(etypes, 'EXGTYPE', simnam_mempath) - ! - ! -- allocate variables + + ! allocate variables call mem_allocate(nummodels, 'NUMMODELS', sim_mempath) call mem_allocate(numexchanges, 'NUMEXCHANGES', sim_mempath) - ! - ! -- set values + + ! set values nummodels = size(mtypes) numexchanges = size(etypes) - ! - ! -- return - return end subroutine simnam_load_dim !> @brief set sim nam input context default integer value @@ -649,10 +571,10 @@ subroutine allocate_simnam_int(input_mempath, idt) character(len=LENMEMPATH), intent(in) :: input_mempath type(InputParamDefinitionType), pointer, intent(in) :: idt integer(I4B), pointer :: intvar - ! - ! -- allocate and set default + + ! allocate and set default call mem_allocate(intvar, idt%mf6varname, input_mempath) - ! + select case (idt%mf6varname) case ('CONTINUE') intvar = isimcontinue @@ -672,9 +594,6 @@ subroutine allocate_simnam_int(input_mempath, idt) call store_error(errmsg) call store_error_filename(simfile) end select - ! - ! -- return - return end subroutine allocate_simnam_int !> @brief MODFLOW 6 mfsim.nam parameter allocate and set @@ -689,35 +608,28 @@ subroutine allocate_simnam_param(input_mempath, idt) character(len=LINELENGTH), pointer :: cstr type(CharacterStringType), dimension(:), & pointer, contiguous :: acharstr1d - ! - ! -- initialize - ! + select case (idt_datatype(idt)) case ('KEYWORD', 'INTEGER') - ! if (idt%in_record) then - ! -- no-op + ! no-op else - ! -- allocate and set default + ! allocate and set default call allocate_simnam_int(input_mempath, idt) end if - ! case ('STRING') - ! - ! -- did this param originate from sim namfile RECARRAY type + ! did this param originate from sim namfile RECARRAY type if (idt%in_record) then - ! - ! -- allocate 0 size CharacterStringType array + ! allocate 0 size CharacterStringType array call mem_allocate(acharstr1d, LINELENGTH, 0, idt%mf6varname, & input_mempath) else - ! - ! -- allocate empty string + ! allocate empty string call mem_allocate(cstr, LINELENGTH, idt%mf6varname, input_mempath) cstr = '' end if case ('RECORD') - ! -- no-op + ! no-op case default write (errmsg, '(a,a)') & 'IdmLoad allocate simnam param unhandled datatype: ', & @@ -725,9 +637,6 @@ subroutine allocate_simnam_param(input_mempath, idt) call store_error(errmsg) call store_error_filename(simfile) end select - ! - ! -- return - return end subroutine allocate_simnam_param !> @brief MODFLOW 6 mfsim.nam input context parameter allocation @@ -741,32 +650,23 @@ subroutine simnam_allocate() type(ModflowInputType) :: mf6_input type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iparam, isize - ! - ! -- set memory path + + ! set memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- create description of input + ! create description of input mf6_input = getModflowInput('NAM6', 'SIM', 'NAM', 'SIM', 'NAM') - ! - ! -- allocate sim namfile parameters if not in input context + + ! allocate sim namfile parameters if not in input context do iparam = 1, size(mf6_input%param_dfns) - ! - ! -- assign param definition pointer + ! assign param definition pointer idt => mf6_input%param_dfns(iparam) - ! - ! -- check if variable is already allocated + ! check if variable is already allocated call get_isize(idt%mf6varname, input_mempath, isize) - ! if (isize < 0) then - ! - ! -- allocate and set parameter + ! allocate and set parameter call allocate_simnam_param(input_mempath, idt) - ! end if end do - ! - ! -- return - return end subroutine simnam_allocate end module IdmLoadModule diff --git a/src/Utilities/Idm/IdmLogger.f90 b/src/Utilities/Idm/IdmLogger.f90 index 8abe33ba633..486f23664d2 100644 --- a/src/Utilities/Idm/IdmLogger.f90 +++ b/src/Utilities/Idm/IdmLogger.f90 @@ -44,7 +44,6 @@ subroutine idm_log_header(component, subcomponent, iout) character(len=*), intent(in) :: component !< component name character(len=*), intent(in) :: subcomponent !< subcomponent name integer(I4B), intent(in) :: iout - if (iparamlog > 0 .and. iout > 0) then write (iout, '(1x,a)') 'Loading input for '//trim(component)//& &'/'//trim(subcomponent) @@ -57,7 +56,6 @@ subroutine idm_log_close(component, subcomponent, iout) character(len=*), intent(in) :: component !< component name character(len=*), intent(in) :: subcomponent !< subcomponent name integer(I4B), intent(in) :: iout - if (iparamlog > 0 .and. iout > 0) then write (iout, '(1x,a)') 'Loading input complete...' end if @@ -69,7 +67,6 @@ subroutine idm_log_period_header(component, iout) use TdisModule, only: kper, kstp character(len=*), intent(in) :: component !< component name integer(I4B), intent(in) :: iout - if (iparamlog > 0 .and. iout > 0 .and. kstp == 1) then write (iout, '(/1x,a,i0,a)') 'IDP PERIOD ', kper, & ' load for component: '//trim(component) @@ -81,7 +78,6 @@ end subroutine idm_log_period_header subroutine idm_log_period_close(iout) use TdisModule, only: kstp integer(I4B), intent(in) :: iout - if (iparamlog > 0 .and. iout > 0 .and. kstp == 1) then !backspace iout write (iout, '(1x,a,/)') 'IDP component dynamic load complete...' @@ -95,7 +91,6 @@ subroutine idm_log_var_ts(varname, mempath, iout, is_tas) character(len=*), intent(in) :: mempath !< variable memory path integer(I4B), intent(in) :: iout logical(LGP), intent(in) :: is_tas - if (iparamlog > 0 .and. iout > 0) then if (is_tas) then write (iout, '(3x, a, ": ", a)') & @@ -115,7 +110,6 @@ subroutine idm_log_var_logical(p_mem, varname, mempath, iout) character(len=*), intent(in) :: mempath !< variable memory path integer(I4B), intent(in) :: iout character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then description = 'Logical detected' write (iout, '(3x, a, ": ", a, " = ", l1)') & @@ -132,7 +126,6 @@ subroutine idm_log_var_int(p_mem, varname, mempath, datatype, iout) character(len=*), intent(in) :: datatype !< variable data type integer(I4B), intent(in) :: iout character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then if (datatype == 'KEYWORD') then description = 'Keyword detected' @@ -154,7 +147,6 @@ subroutine idm_log_var_int1d(p_mem, varname, mempath, iout) integer(I4B), intent(in) :: iout integer(I4B) :: min_val, max_val character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then min_val = minval(p_mem) max_val = maxval(p_mem) @@ -180,7 +172,6 @@ subroutine idm_log_var_int2d(p_mem, varname, mempath, iout) integer(I4B), intent(in) :: iout integer(I4B) :: min_val, max_val character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then min_val = minval(p_mem) max_val = maxval(p_mem) @@ -206,7 +197,6 @@ subroutine idm_log_var_int3d(p_mem, varname, mempath, iout) integer(I4B), intent(in) :: iout integer(I4B) :: min_val, max_val character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then min_val = minval(p_mem) max_val = maxval(p_mem) @@ -231,7 +221,6 @@ subroutine idm_log_var_dbl(p_mem, varname, mempath, iout) character(len=*), intent(in) :: mempath !< variable memory path integer(I4B), intent(in) :: iout character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then description = 'Double detected' write (iout, '(3x, a, ": ", a, " = ", G0)') & @@ -248,7 +237,6 @@ subroutine idm_log_var_dbl1d(p_mem, varname, mempath, iout) integer(I4B), intent(in) :: iout real(DP) :: min_val, max_val character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then min_val = minval(p_mem) max_val = maxval(p_mem) @@ -274,7 +262,6 @@ subroutine idm_log_var_dbl2d(p_mem, varname, mempath, iout) integer(I4B), intent(in) :: iout real(DP) :: min_val, max_val character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then min_val = minval(p_mem) max_val = maxval(p_mem) @@ -300,7 +287,6 @@ subroutine idm_log_var_dbl3d(p_mem, varname, mempath, iout) integer(I4B), intent(in) :: iout real(DP) :: min_val, max_val character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then min_val = minval(p_mem) max_val = maxval(p_mem) @@ -325,7 +311,6 @@ subroutine idm_log_var_str(p_mem, varname, mempath, iout) character(len=*), intent(in) :: mempath !< variable memory path integer(I4B), intent(in) :: iout character(len=LINELENGTH) :: description - if (iparamlog > 0 .and. iout > 0) then description = 'String detected' write (iout, '(3x, a, ": ", a, " = ", a)') & @@ -346,7 +331,6 @@ subroutine idm_export_int1d(p_mem, varname, mempath, shapestr, iout) character(len=*), intent(in) :: mempath !< variable memory path character(len=*), intent(in) :: shapestr !< dfn shape string integer(I4B), intent(in) :: iout - ! -- dummy integer(I4B), dimension(:), pointer, contiguous :: model_shape integer(I4B), dimension(:, :, :), pointer, contiguous :: int3d integer(I4B), dimension(:, :), pointer, contiguous :: int2d @@ -357,27 +341,27 @@ subroutine idm_export_int1d(p_mem, varname, mempath, shapestr, iout) character(LENCOMPONENTNAME) :: comp, subcomp integer(I4B) :: i, j, k, inunit, export_dim logical(LGP) :: is_layered - ! - ! -- set pointer to DISENUM and MODEL_SHAPE + + ! set pointer to DISENUM and MODEL_SHAPE call split_mem_path(mempath, comp, subcomp) input_mempath = create_mem_path(component=comp, context=idm_context) call mem_setptr(distype, 'DISENUM', input_mempath) call mem_setptr(model_shape, 'MODEL_SHAPE', input_mempath) - ! - ! -- set export_dim + + ! set export_dim export_dim = distype_export_dim(distype, shapestr, is_layered) - ! - ! -- create export file(s) + + ! create export file(s) select case (export_dim) case (3) - ! -- set reshape array + ! set reshape array dis3d_shape(1) = model_shape(3) dis3d_shape(2) = model_shape(2) dis3d_shape(3) = model_shape(1) - ! -- allocate and reshape + ! allocate and reshape allocate (int3d(dis3d_shape(1), dis3d_shape(2), dis3d_shape(3))) int3d = reshape(p_mem, dis3d_shape) - ! -- write export files 3D array + ! write export files 3D array do k = 1, dis3d_shape(3) inunit = create_export_file(varname, mempath, k, iout) do i = 1, model_shape(2) @@ -386,34 +370,34 @@ subroutine idm_export_int1d(p_mem, varname, mempath, shapestr, iout) end do close (inunit) end do - ! -- cleanup + ! cleanup deallocate (int3d) case (2) - ! -- set reshape array + ! set reshape array dis2d_shape(1) = model_shape(2) dis2d_shape(2) = model_shape(1) - ! -- allocate and reshape + ! allocate and reshape allocate (int2d(dis2d_shape(1), dis2d_shape(2))) int2d = reshape(p_mem, dis2d_shape) if (is_layered) then - ! -- write layered export files 2D array + ! write layered export files 2D array do i = 1, dis2d_shape(2) inunit = create_export_file(varname, mempath, i, iout) write (inunit, '(*(i0, " "))') (int2d(j, i), j=1, dis2d_shape(1)) close (inunit) end do else - ! -- write export file 2D array + ! write export file 2D array inunit = create_export_file(varname, mempath, 0, iout) do i = 1, dis2d_shape(2) write (inunit, '(*(i0, " "))') (int2d(j, i), j=1, dis2d_shape(1)) end do close (inunit) end if - ! -- cleanup + ! cleanup deallocate (int2d) case (1) - ! -- write export file 1D array + ! write export file 1D array inunit = create_export_file(varname, mempath, 0, iout) write (inunit, '(*(i0, " "))') p_mem close (inunit) @@ -434,26 +418,25 @@ subroutine idm_export_int2d(p_mem, varname, mempath, shapestr, iout) character(len=*), intent(in) :: mempath !< variable memory path character(len=*), intent(in) :: shapestr !< dfn shape string integer(I4B), intent(in) :: iout - ! -- dummy integer(I4B), dimension(:), pointer, contiguous :: model_shape integer(I4B), pointer :: distype character(LENMEMPATH) :: input_mempath character(LENCOMPONENTNAME) :: comp, subcomp integer(I4B) :: i, j, inunit, export_dim logical(LGP) :: is_layered - ! - ! -- set pointer to DISENUM + + ! set pointer to DISENUM call split_mem_path(mempath, comp, subcomp) input_mempath = create_mem_path(component=comp, context=idm_context) call mem_setptr(distype, 'DISENUM', input_mempath) call mem_setptr(model_shape, 'MODEL_SHAPE', input_mempath) - ! - ! -- set export_dim + + ! set export_dim export_dim = distype_export_dim(distype, shapestr, is_layered) - ! + select case (export_dim) case (1) - ! -- write export file 1D array + ! write export file 1D array inunit = create_export_file(varname, mempath, 0, iout) do i = 1, size(p_mem, dim=2) write (inunit, '(*(i0, " "))') (p_mem(j, i), j=1, size(p_mem, dim=1)) @@ -461,14 +444,14 @@ subroutine idm_export_int2d(p_mem, varname, mempath, shapestr, iout) close (inunit) case (2) if (is_layered) then - ! -- write layered export files 2D array + ! write layered export files 2D array do i = 1, size(p_mem, dim=2) inunit = create_export_file(varname, mempath, i, iout) write (inunit, '(*(i0, " "))') (p_mem(j, i), j=1, size(p_mem, dim=1)) close (inunit) end do else - ! -- write export file 2D array + ! write export file 2D array inunit = create_export_file(varname, mempath, 0, iout) do i = 1, size(p_mem, dim=2) write (inunit, '(*(i0, " "))') (p_mem(j, i), j=1, size(p_mem, dim=1)) @@ -492,26 +475,25 @@ subroutine idm_export_int3d(p_mem, varname, mempath, shapestr, iout) character(len=*), intent(in) :: mempath !< variable memory path character(len=*), intent(in) :: shapestr !< dfn shape string integer(I4B), intent(in) :: iout - ! -- dummy integer(I4B), dimension(:), pointer, contiguous :: model_shape integer(I4B), pointer :: distype character(LENMEMPATH) :: input_mempath character(LENCOMPONENTNAME) :: comp, subcomp integer(I4B) :: i, j, k, inunit, export_dim logical(LGP) :: is_layered - ! - ! -- set pointer to DISENUM + + ! set pointer to DISENUM call split_mem_path(mempath, comp, subcomp) input_mempath = create_mem_path(component=comp, context=idm_context) call mem_setptr(distype, 'DISENUM', input_mempath) call mem_setptr(model_shape, 'MODEL_SHAPE', input_mempath) - ! - ! -- set export_dim + + ! set export_dim export_dim = distype_export_dim(distype, shapestr, is_layered) - ! + select case (export_dim) case (3) - ! -- write export files 3D array + ! write export files 3D array do k = 1, size(p_mem, dim=3) inunit = create_export_file(varname, mempath, k, iout) do i = 1, size(p_mem, dim=2) @@ -539,7 +521,6 @@ subroutine idm_export_dbl1d(p_mem, varname, mempath, shapestr, iout) character(len=*), intent(in) :: mempath !< variable memory path character(len=*), intent(in) :: shapestr !< dfn shape string integer(I4B), intent(in) :: iout - ! -- dummy integer(I4B), dimension(:), pointer, contiguous :: model_shape real(DP), dimension(:, :, :), pointer, contiguous :: dbl3d real(DP), dimension(:, :), pointer, contiguous :: dbl2d @@ -550,28 +531,28 @@ subroutine idm_export_dbl1d(p_mem, varname, mempath, shapestr, iout) character(LENCOMPONENTNAME) :: comp, subcomp integer(I4B) :: i, j, k, inunit, export_dim logical(LGP) :: is_layered - ! - ! -- set pointer to DISENUM and MODEL_SHAPE + + ! set pointer to DISENUM and MODEL_SHAPE call split_mem_path(mempath, comp, subcomp) input_mempath = create_mem_path(component=comp, context=idm_context) call mem_setptr(distype, 'DISENUM', input_mempath) call mem_setptr(model_shape, 'MODEL_SHAPE', input_mempath) - ! - ! -- set export_dim + + ! set export_dim export_dim = distype_export_dim(distype, shapestr, is_layered) - ! - ! -- create export file(s) + + ! create export file(s) select case (export_dim) case (3) - ! -- set reshape array + ! set reshape array dis3d_shape(1) = model_shape(3) dis3d_shape(2) = model_shape(2) - ! -- allocate and reshape + ! allocate and reshape dis3d_shape(3) = model_shape(1) allocate (dbl3d(dis3d_shape(1), dis3d_shape(2), dis3d_shape(3))) dbl3d = reshape(p_mem, dis3d_shape) do k = 1, dis3d_shape(3) - ! -- write export files 3D array + ! write export files 3D array inunit = create_export_file(varname, mempath, k, iout) do i = 1, model_shape(2) write (inunit, '(*(G0.10, " "))') (dbl3d(j, i, k), j=1, & @@ -579,34 +560,34 @@ subroutine idm_export_dbl1d(p_mem, varname, mempath, shapestr, iout) end do close (inunit) end do - ! -- cleanup + ! cleanup deallocate (dbl3d) case (2) - ! -- set reshape array + ! set reshape array dis2d_shape(1) = model_shape(2) dis2d_shape(2) = model_shape(1) - ! -- allocate and reshape + ! allocate and reshape allocate (dbl2d(dis2d_shape(1), dis2d_shape(2))) dbl2d = reshape(p_mem, dis2d_shape) if (is_layered) then - ! -- write layered export files 2D array + ! write layered export files 2D array do i = 1, dis2d_shape(2) inunit = create_export_file(varname, mempath, i, iout) write (inunit, '(*(G0.10, " "))') (dbl2d(j, i), j=1, dis2d_shape(1)) close (inunit) end do else - ! -- write export file 2D array + ! write export file 2D array inunit = create_export_file(varname, mempath, 0, iout) do i = 1, dis2d_shape(2) write (inunit, '(*(G0.10, " "))') (dbl2d(j, i), j=1, dis2d_shape(1)) end do close (inunit) end if - ! -- cleanup + ! cleanup deallocate (dbl2d) case (1) - ! -- write export file 1D array + ! write export file 1D array inunit = create_export_file(varname, mempath, 0, iout) write (inunit, '(*(G0.10, " "))') p_mem close (inunit) @@ -627,26 +608,25 @@ subroutine idm_export_dbl2d(p_mem, varname, mempath, shapestr, iout) character(len=*), intent(in) :: mempath !< variable memory path character(len=*), intent(in) :: shapestr !< dfn shape string integer(I4B), intent(in) :: iout - ! -- dummy integer(I4B), dimension(:), pointer, contiguous :: model_shape integer(I4B), pointer :: distype character(LENMEMPATH) :: input_mempath character(LENCOMPONENTNAME) :: comp, subcomp integer(I4B) :: i, j, inunit, export_dim logical(LGP) :: is_layered - ! - ! -- set pointer to DISENUM + + ! set pointer to DISENUM call split_mem_path(mempath, comp, subcomp) input_mempath = create_mem_path(component=comp, context=idm_context) call mem_setptr(distype, 'DISENUM', input_mempath) call mem_setptr(model_shape, 'MODEL_SHAPE', input_mempath) - ! - ! -- set export_dim + + ! set export_dim export_dim = distype_export_dim(distype, shapestr, is_layered) - ! + select case (export_dim) case (1) - ! -- write export file 1D array + ! write export file 1D array inunit = create_export_file(varname, mempath, 0, iout) do i = 1, size(p_mem, dim=2) write (inunit, '(*(G0.10, " "))') (p_mem(j, i), j=1, size(p_mem, dim=1)) @@ -654,14 +634,14 @@ subroutine idm_export_dbl2d(p_mem, varname, mempath, shapestr, iout) close (inunit) case (2) if (is_layered) then - ! -- write layered export files 2D array + ! write layered export files 2D array do i = 1, size(p_mem, dim=2) inunit = create_export_file(varname, mempath, i, iout) write (inunit, '(*(G0.10, " "))') (p_mem(j, i), j=1, size(p_mem, dim=1)) close (inunit) end do else - ! -- write export file 2D array + ! write export file 2D array inunit = create_export_file(varname, mempath, 0, iout) do i = 1, size(p_mem, dim=2) write (inunit, '(*(G0.10, " "))') (p_mem(j, i), j=1, size(p_mem, dim=1)) @@ -685,26 +665,25 @@ subroutine idm_export_dbl3d(p_mem, varname, mempath, shapestr, iout) character(len=*), intent(in) :: mempath !< variable memory path character(len=*), intent(in) :: shapestr !< dfn shape string integer(I4B), intent(in) :: iout - ! -- dummy integer(I4B), dimension(:), pointer, contiguous :: model_shape integer(I4B), pointer :: distype character(LENMEMPATH) :: input_mempath character(LENCOMPONENTNAME) :: comp, subcomp integer(I4B) :: i, j, k, inunit, export_dim logical(LGP) :: is_layered - ! - ! -- set pointer to DISENUM + + ! set pointer to DISENUM call split_mem_path(mempath, comp, subcomp) input_mempath = create_mem_path(component=comp, context=idm_context) call mem_setptr(distype, 'DISENUM', input_mempath) call mem_setptr(model_shape, 'MODEL_SHAPE', input_mempath) - ! - ! -- set export_dim + + ! set export_dim export_dim = distype_export_dim(distype, shapestr, is_layered) - ! + select case (export_dim) case (3) - ! -- write export files 3D array + ! write export files 3D array do k = 1, size(p_mem, dim=3) inunit = create_export_file(varname, mempath, k, iout) do i = 1, size(p_mem, dim=2) @@ -730,10 +709,10 @@ function distype_export_dim(distype, shapestr, is_layered) & character(len=*), intent(in) :: shapestr !< dfn shape string logical(LGP), intent(inout) :: is_layered !< does this data represent layers integer(I4B) :: export_dim - ! - ! -- initialize is_layered to false + + ! initialize is_layered to false is_layered = .false. - ! + select case (distype) case (DIS) if (shapestr == 'NODES') then @@ -789,27 +768,26 @@ function create_export_file(varname, mempath, layer, iout) & integer(I4B), intent(in) :: layer integer(I4B), intent(in) :: iout integer(I4B) :: inunit - ! -- dummy character(len=LENCOMPONENTNAME) :: comp, subcomp character(len=LINELENGTH) :: filename, suffix - ! - ! -- split the mempath + + ! split the mempath call split_mem_path(mempath, comp, subcomp) call lowcase(comp) call lowcase(subcomp) - ! - ! -- build suffix + + ! build suffix suffix = varname call lowcase(suffix) if (layer > 0) then write (suffix, '(a,i0)') trim(suffix)//'.l', layer end if suffix = trim(suffix)//'.txt' - ! - ! -- set filename + + ! set filename filename = trim(comp)//'-'//trim(subcomp)//'.'//trim(suffix) - ! - ! -- silently create the array file + + ! silently create the array file inunit = getunit() call openfile(inunit, 0, filename, 'EXPORT', filstat_opt='REPLACE') end function create_export_file diff --git a/src/Utilities/Idm/InputLoadType.f90 b/src/Utilities/Idm/InputLoadType.f90 index 32d947c6271..8dfe53e66ba 100644 --- a/src/Utilities/Idm/InputLoadType.f90 +++ b/src/Utilities/Idm/InputLoadType.f90 @@ -150,19 +150,16 @@ subroutine period_load_if(this) !> @brief create a new package type !< subroutine subpkg_create(this, mempath, component_name) - ! -- modules - ! -- dummy class(SubPackageListType) :: this character(len=*), intent(in) :: mempath character(len=*), intent(in) :: component_name - ! -- local - ! - ! -- initialize + + ! initialize this%pnum = 0 this%mempath = mempath this%component_name = component_name - ! - ! -- allocate arrays + + ! allocate arrays allocate (this%pkgtypes(0)) allocate (this%component_types(0)) allocate (this%subcomponent_types(0)) @@ -173,60 +170,57 @@ end subroutine subpkg_create !< subroutine subpkg_add(this, pkgtype, component_type, subcomponent_type, & tagname, filename) - ! -- modules use ArrayHandlersModule, only: expandarray use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_allocate use SimVariablesModule, only: idm_context - ! -- dummy class(SubPackageListType) :: this character(len=*), intent(in) :: pkgtype character(len=*), intent(in) :: component_type character(len=*), intent(in) :: subcomponent_type character(len=*), intent(in) :: tagname character(len=*), intent(in) :: filename - ! -- local character(len=LENVARNAME) :: mempath_tag character(len=LENMEMPATH), pointer :: subpkg_mempath character(len=LINELENGTH), pointer :: input_fname integer(I4B) :: idx, trimlen - ! - ! -- reallocate + + ! reallocate call expandarray(this%pkgtypes) call expandarray(this%component_types) call expandarray(this%subcomponent_types) call expandarray(this%filenames) - ! - ! -- add new package instance + + ! add new package instance this%pnum = this%pnum + 1 this%pkgtypes(this%pnum) = pkgtype this%component_types(this%pnum) = component_type this%subcomponent_types(this%pnum) = subcomponent_type this%filenames(this%pnum) = filename - ! - ! -- initialize mempath tag + + ! initialize mempath tag mempath_tag = tagname trimlen = len_trim(tagname) idx = 0 - ! - ! -- create mempath tagname + + ! create mempath tagname idx = index(tagname, '_') if (idx > 0) then if (tagname(idx + 1:trimlen) == 'FILENAME') then write (mempath_tag, '(a)') tagname(1:idx)//'MEMPATH' end if end if - ! - ! -- allocate mempath variable for subpackage + + ! allocate mempath variable for subpackage call mem_allocate(subpkg_mempath, LENMEMPATH, mempath_tag, & this%mempath) - ! - ! -- create and set the mempath + + ! create and set the mempath subpkg_mempath = & create_mem_path(this%component_name, & subcomponent_type, idm_context) - ! - ! -- allocate and initialize filename for subpackage + + ! allocate and initialize filename for subpackage call mem_allocate(input_fname, LINELENGTH, 'INPUT_FNAME', subpkg_mempath) input_fname = filename end subroutine subpkg_add @@ -234,12 +228,8 @@ end subroutine subpkg_add !> @brief create a new package type !< subroutine subpkg_destroy(this) - ! -- modules - ! -- dummy class(SubPackageListType) :: this - ! -- local - ! - ! -- allocate arrays + ! allocate arrays deallocate (this%pkgtypes) deallocate (this%component_types) deallocate (this%subcomponent_types) @@ -257,27 +247,24 @@ subroutine static_init(this, mf6_input, component_name, component_input_name, & character(len=*), intent(in) :: component_input_name character(len=*), intent(in) :: input_name integer(I4B) :: iblock - ! + this%mf6_input = mf6_input this%component_name = component_name this%component_input_name = component_input_name this%input_name = input_name this%iperblock = 0 - ! - ! -- create subpackage list + + ! create subpackage list call this%subpkg_list%create(this%mf6_input%mempath, & this%mf6_input%component_name) - ! - ! -- identify period block definition + + ! identify period block definition do iblock = 1, size(mf6_input%block_dfns) - ! if (mf6_input%block_dfns(iblock)%blockname == 'PERIOD') then this%iperblock = iblock exit end if end do - ! - return end subroutine static_init !> @brief create the subpackage list @@ -293,28 +280,25 @@ subroutine create_subpkg_list(this) character(len=LENFTYPE) :: c_type, sc_type character(len=16) :: subpkg integer(I4B) :: idx, n - ! - ! -- set pointer to package (idm integrated) subpackage list + + ! set pointer to package (idm integrated) subpackage list subpkgs => idm_subpackages(this%mf6_input%component_type, & this%mf6_input%subcomponent_type) - ! - ! -- check if tag matches subpackage + + ! check if tag matches subpackage do n = 1, size(subpkgs) subpkg = subpkgs(n) idx = index(subpkg, '-') - ! -- split sp string into component/subcomponent + ! split sp string into component/subcomponent if (idx > 0) then - ! -- split string in component/subcomponent types + ! split string in component/subcomponent types c_type = subpkg(1:idx - 1) sc_type = subpkg(idx + 1:len_trim(subpkg)) - ! if (idm_integrated(c_type, sc_type)) then - ! - ! -- set pkgtype and input filename tag + ! set pkgtype and input filename tag pkgtype = trim(sc_type)//'6' tag = trim(pkgtype)//'_FILENAME' - ! - ! -- support single instance of each subpackage + ! support single instance of each subpackage if (idm_multi_package(c_type, sc_type)) then errmsg = 'Multi-instance subpackages not supported. Remove dfn & &subpackage tagline for package "'//trim(subpkg)//'".' @@ -339,16 +323,12 @@ end subroutine create_subpkg_list subroutine static_destroy(this) class(StaticPkgLoadType), intent(inout) :: this - ! call this%subpkg_list%destroy() - ! if (associated(this%nc_vars)) then call this%nc_vars%destroy() deallocate (this%nc_vars) nullify (this%nc_vars) end if - ! - return end subroutine static_destroy !> @brief initialize dynamic package loader @@ -361,7 +341,6 @@ subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & input_name, iperblock, iout) use SimVariablesModule, only: errmsg use InputDefinitionModule, only: InputParamDefinitionType - ! -- dummy class(DynamicPkgLoadType), intent(inout) :: this type(ModflowInputType), intent(in) :: mf6_input character(len=*), intent(in) :: component_name @@ -370,7 +349,7 @@ subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & integer(I4B), intent(in) :: iperblock integer(I4B), intent(in) :: iout type(InputParamDefinitionType), pointer :: idt - ! + this%mf6_input = mf6_input this%component_name = component_name this%component_input_name = component_input_name @@ -379,8 +358,8 @@ subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & this%nparam = 0 this%iout = iout nullify (idt) - ! - ! -- throw error and exit if not found + + ! throw error and exit if not found if (this%iperblock == 0) then write (errmsg, '(a,a)') & 'Programming error. (IDM) PERIOD block not found in '& @@ -389,8 +368,8 @@ subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & call store_error(errmsg) call store_error_filename(this%input_name) end if - ! - ! -- set readasarrays + + ! set readasarrays this%readasarrays = (.not. mf6_input%block_dfns(iperblock)%aggregate) end subroutine dynamic_init @@ -399,10 +378,7 @@ end subroutine dynamic_init !< subroutine dynamic_df(this) class(DynamicPkgLoadType), intent(inout) :: this - ! ! override in derived type - ! - return end subroutine dynamic_df !> @brief dynamic package loader advance @@ -410,10 +386,7 @@ end subroutine dynamic_df !< subroutine dynamic_ad(this) class(DynamicPkgLoadType), intent(inout) :: this - ! ! override in derived type - ! - return end subroutine dynamic_ad !> @brief dynamic package loader destroy @@ -424,20 +397,18 @@ subroutine dynamic_destroy(this) use MemoryManagerExtModule, only: memorystore_remove use SimVariablesModule, only: idm_context class(DynamicPkgLoadType), intent(inout) :: this - ! - ! -- clean up netcdf variables structure + + ! clean up netcdf variables structure if (associated(this%nc_vars)) then call this%nc_vars%destroy() deallocate (this%nc_vars) nullify (this%nc_vars) end if - ! - ! -- deallocate package static and dynamic input context + + ! deallocate package static and dynamic input context call memorystore_remove(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, & idm_context) - ! - return end subroutine dynamic_destroy !> @brief model dynamic packages init @@ -452,15 +423,12 @@ subroutine dynamicpkgs_init(this, modeltype, modelname, modelfname, nc_fname, & character(len=*), intent(in) :: nc_fname integer(I4B), intent(in) :: ncid integer(I4B), intent(in) :: iout - ! this%modeltype = modeltype this%modelname = modelname this%modelfname = modelfname this%nc_fname = nc_fname this%ncid = ncid this%iout = iout - ! - return end subroutine dynamicpkgs_init !> @brief add package to model dynamic packages list @@ -470,11 +438,8 @@ subroutine dynamicpkgs_add(this, dynamic_pkg) class(ModelDynamicPkgsType), intent(inout) :: this class(DynamicPkgLoadBaseType), pointer, intent(inout) :: dynamic_pkg class(*), pointer :: obj - ! obj => dynamic_pkg call this%pkglist%add(obj) - ! - return end subroutine dynamicpkgs_add !> @brief retrieve package from model dynamic packages list @@ -485,18 +450,14 @@ function dynamicpkgs_get(this, idx) result(res) integer(I4B), intent(in) :: idx class(DynamicPkgLoadBaseType), pointer :: res class(*), pointer :: obj - ! nullify (res) obj => this%pkglist%GetItem(idx) - ! if (associated(obj)) then select type (obj) class is (DynamicPkgLoadBaseType) res => obj end select end if - ! - return end function dynamicpkgs_get !> @brief read and prepare model dynamic packages @@ -507,17 +468,12 @@ subroutine dynamicpkgs_rp(this) class(ModelDynamicPkgsType), intent(inout) :: this class(DynamicPkgLoadBaseType), pointer :: dynamic_pkg integer(I4B) :: n - ! call idm_log_period_header(this%modelname, this%iout) - ! do n = 1, this%pkglist%Count() dynamic_pkg => this%get(n) call dynamic_pkg%rp() end do - ! call idm_log_period_close(this%iout) - ! - return end subroutine dynamicpkgs_rp !> @brief define model dynamic packages @@ -527,13 +483,10 @@ subroutine dynamicpkgs_df(this) class(ModelDynamicPkgsType), intent(inout) :: this class(DynamicPkgLoadBaseType), pointer :: dynamic_pkg integer(I4B) :: n - ! do n = 1, this%pkglist%Count() dynamic_pkg => this%get(n) call dynamic_pkg%df() end do - ! - return end subroutine dynamicpkgs_df !> @brief advance model dynamic packages @@ -543,13 +496,10 @@ subroutine dynamicpkgs_ad(this) class(ModelDynamicPkgsType), intent(inout) :: this class(DynamicPkgLoadBaseType), pointer :: dynamic_pkg integer(I4B) :: n - ! do n = 1, this%pkglist%Count() dynamic_pkg => this%get(n) call dynamic_pkg%ad() end do - ! - return end subroutine dynamicpkgs_ad !> @brief get size of model dynamic packages list @@ -558,10 +508,7 @@ end subroutine dynamicpkgs_ad function dynamicpkgs_size(this) result(size) class(ModelDynamicPkgsType), intent(inout) :: this integer(I4B) :: size - ! size = this%pkglist%Count() - ! - return end function dynamicpkgs_size !> @brief destroy model dynamic packages object @@ -571,30 +518,23 @@ subroutine dynamicpkgs_destroy(this) class(ModelDynamicPkgsType), intent(inout) :: this class(DynamicPkgLoadBaseType), pointer :: dynamic_pkg integer(I4B) :: n - ! - ! -- destroy dynamic loaders + ! destroy dynamic loaders do n = 1, this%pkglist%Count() dynamic_pkg => this%get(n) call dynamic_pkg%destroy() deallocate (dynamic_pkg) nullify (dynamic_pkg) end do - ! call this%pkglist%Clear() - ! - return end subroutine dynamicpkgs_destroy !> @brief add model dynamic packages object to list !! !< subroutine AddDynamicModelToList(list, model_dynamic) - ! -- dummy variables type(ListType), intent(inout) :: list !< package list class(ModelDynamicPkgsType), pointer, intent(inout) :: model_dynamic - ! -- local variables class(*), pointer :: obj - ! obj => model_dynamic call list%Add(obj) end subroutine AddDynamicModelToList @@ -603,17 +543,13 @@ end subroutine AddDynamicModelToList !! !< function GetDynamicModelFromList(list, idx) result(res) - ! -- dummy variables type(ListType), intent(inout) :: list !< spd list integer(I4B), intent(in) :: idx !< package number class(ModelDynamicPkgsType), pointer :: res - ! -- local variables class(*), pointer :: obj - ! - ! -- initialize res + ! initialize res nullify (res) - ! - ! -- get the object from the list + ! get the object from the list obj => list%GetItem(idx) if (associated(obj)) then select type (obj) diff --git a/src/Utilities/Idm/ModelPackageInputs.f90 b/src/Utilities/Idm/ModelPackageInputs.f90 index 24f35cdb88e..2cc4c9bdbda 100644 --- a/src/Utilities/Idm/ModelPackageInputs.f90 +++ b/src/Utilities/Idm/ModelPackageInputs.f90 @@ -26,16 +26,16 @@ module ModelPackageInputsModule !! !< type :: LoadablePackageType - ! -- package type, e.g. 'DIS6' or 'CHD6' + ! package type, e.g. 'DIS6' or 'CHD6' character(len=LENPACKAGETYPE) :: pkgtype - ! -- component type, e.g. 'DIS' or 'CHD' + ! component type, e.g. 'DIS' or 'CHD' character(len=LENCOMPONENTNAME) :: subcomponent_type - ! -- package instance attribute arrays + ! package instance attribute arrays character(len=LINELENGTH), dimension(:), allocatable :: filenames character(len=LENPACKAGENAME), dimension(:), allocatable :: pkgnames character(len=LENMEMPATH), dimension(:), allocatable :: mempaths integer(I4B), dimension(:), allocatable :: inunits - ! -- number of package instances + ! number of package instances integer(I4B) :: pnum contains procedure :: create => pkgtype_create @@ -50,16 +50,16 @@ module ModelPackageInputsModule !! !< type :: ModelPackageInputsType - ! -- model attributes - character(len=LENPACKAGETYPE) :: modeltype ! -- model type, e.g. 'GWF6' + ! model attributes + character(len=LENPACKAGETYPE) :: modeltype ! model type, e.g. 'GWF6' character(len=LINELENGTH) :: modelfname character(len=LENMODELNAME) :: modelname - ! -- component type - character(len=LENCOMPONENTNAME) :: component_type ! -- e.g. 'GWF' - ! -- mempaths + ! component type + character(len=LENCOMPONENTNAME) :: component_type ! e.g. 'GWF' + ! mempaths character(len=LENMEMPATH) :: input_mempath character(len=LENMEMPATH) :: model_mempath - ! -- pointers to created managed memory + ! pointers to created managed memory type(CharacterStringType), dimension(:), contiguous, & pointer :: pkgtypes => null() type(CharacterStringType), dimension(:), contiguous, & @@ -68,12 +68,12 @@ module ModelPackageInputsModule pointer :: mempaths => null() integer(I4B), dimension(:), contiguous, & pointer :: inunits => null() - ! -- loadable package type array + ! loadable package type array type(LoadablePackageType), dimension(:), allocatable :: pkglist - ! -- pkgtype definitions + ! pkgtype definitions integer(I4B) :: niunit character(len=LENPACKAGETYPE), dimension(:), allocatable :: cunit - ! -- out handle + ! out handle integer(I4B) :: iout contains procedure :: init => modelpkgs_init @@ -91,70 +91,51 @@ module ModelPackageInputsModule !< function multi_pkg_type(mtype_component, ptype_component, pkgtype) & result(multi_pkg) - ! -- modules use IdmDfnSelectorModule, only: idm_integrated, idm_multi_package use ModelPackageInputModule, only: multi_package_type - ! -- dummy character(len=LENCOMPONENTNAME), intent(in) :: mtype_component character(len=LENCOMPONENTNAME), intent(in) :: ptype_component character(len=LENFTYPE), intent(in) :: pkgtype - ! -- return logical(LGP) :: multi_pkg - ! -- local - ! multi_pkg = .false. - ! if (idm_integrated(mtype_component, ptype_component)) then multi_pkg = idm_multi_package(mtype_component, ptype_component) - ! else multi_pkg = multi_package_type(mtype_component, ptype_component, pkgtype) - ! end if - ! - ! -- return - return end function multi_pkg_type !> @brief create a new package type !< subroutine pkgtype_create(this, modeltype, modelname, pkgtype) - ! -- modules use SourceCommonModule, only: idm_subcomponent_type - ! -- dummy class(LoadablePackageType) :: this character(len=*), intent(in) :: modeltype character(len=*), intent(in) :: modelname character(len=*), intent(in) :: pkgtype - ! -- local - ! - ! -- initialize + + ! initialize this%pkgtype = pkgtype this%subcomponent_type = idm_subcomponent_type(modeltype, pkgtype) this%pnum = 0 - ! - ! -- allocate arrays + + ! allocate arrays allocate (this%filenames(0)) allocate (this%pkgnames(0)) allocate (this%mempaths(0)) allocate (this%inunits(0)) - ! - ! -- return - return end subroutine pkgtype_create !> @brief add a new package instance to this package type !< subroutine pkgtype_add(this, modelname, mtype_component, filetype, & filename, pkgname, iout) - ! -- modules use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path use MemoryManagerExtModule, only: mem_set_value use SimVariablesModule, only: idm_context use IdmDfnSelectorModule, only: idm_integrated, idm_multi_package use SourceCommonModule, only: idm_subcomponent_name - ! -- dummy class(LoadablePackageType) :: this character(len=*), intent(in) :: modelname character(len=*), intent(in) :: mtype_component @@ -162,24 +143,23 @@ subroutine pkgtype_add(this, modelname, mtype_component, filetype, & character(len=*), intent(in) :: filename character(len=*), intent(in) :: pkgname integer(I4B), intent(in) :: iout - ! -- local character(len=LENPACKAGENAME) :: sc_name, pname character(len=LENMEMPATH) :: mempath character(len=LINELENGTH), pointer :: cstr - ! - ! -- reallocate + + ! reallocate call expandarray(this%filenames) call expandarray(this%pkgnames) call expandarray(this%inunits) call expandarray(this%mempaths) - ! - ! -- add new package instance + + ! add new package instance this%pnum = this%pnum + 1 this%filenames(this%pnum) = filename this%pkgnames(this%pnum) = pkgname this%inunits(this%pnum) = 0 - ! - ! -- set pkgname if empty + + ! set pkgname if empty if (this%pkgnames(this%pnum) == '') then if (multi_pkg_type(mtype_component, & this%subcomponent_type, & @@ -190,84 +170,65 @@ subroutine pkgtype_add(this, modelname, mtype_component, filetype, & end if this%pkgnames(this%pnum) = pname end if - ! - ! -- set up input context for model + + ! set up input context for model if (idm_integrated(mtype_component, this%subcomponent_type)) then - ! - ! -- set subcomponent name + ! set subcomponent name sc_name = idm_subcomponent_name(mtype_component, this%subcomponent_type, & this%pkgnames(this%pnum)) - ! - ! -- create and store the mempath + ! create and store the mempath this%mempaths(this%pnum) = & create_mem_path(modelname, sc_name, idm_context) - ! - ! -- allocate and initialize filename for package + ! allocate and initialize filename for package mempath = create_mem_path(modelname, sc_name, idm_context) call mem_allocate(cstr, LINELENGTH, 'INPUT_FNAME', mempath) cstr = filename - ! else - ! - ! -- set mempath empty + ! set mempath empty this%mempaths(this%pnum) = '' end if - ! - ! -- return - return end subroutine pkgtype_add !> @brief deallocate object !< subroutine pkgtype_destroy(this) - ! -- modules - ! -- dummy class(LoadablePackageType) :: this - ! -- local - ! - ! -- deallocate dynamic arrays + ! deallocate dynamic arrays deallocate (this%filenames) deallocate (this%pkgnames) deallocate (this%inunits) deallocate (this%mempaths) - ! - ! -- return - return end subroutine pkgtype_destroy !> @brief initialize model package inputs object !< subroutine modelpkgs_init(this, modeltype, modelfname, modelname, iout) - ! -- modules use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_allocate use SimVariablesModule, only: idm_context use SourceCommonModule, only: idm_component_type use ModelPackageInputModule, only: supported_model_packages - ! -- dummy class(ModelPackageInputsType) :: this character(len=*), intent(in) :: modeltype character(len=*), intent(in) :: modelfname character(len=*), intent(in) :: modelname integer(I4B), intent(in) :: iout - ! -- local - ! - ! -- initialize object + + ! initialize object this%modeltype = modeltype this%modelfname = modelfname this%modelname = modelname this%component_type = idm_component_type(modeltype) this%iout = iout - ! - ! -- allocate and set model supported package types + + ! allocate and set model supported package types call supported_model_packages(modeltype, this%cunit, this%niunit) - ! - ! -- set memory paths + + ! set memory paths this%input_mempath = create_mem_path(this%modelname, 'NAM', idm_context) this%model_mempath = create_mem_path(component=this%modelname, & context=idm_context) - ! - ! -- allocate managed memory + ! allocate managed memory call mem_allocate(this%pkgtypes, LENPACKAGETYPE, 0, 'PKGTYPES', & this%model_mempath) call mem_allocate(this%pkgnames, LENPACKAGENAME, 0, 'PKGNAMES', & @@ -275,59 +236,52 @@ subroutine modelpkgs_init(this, modeltype, modelfname, modelname, iout) call mem_allocate(this%mempaths, LENMEMPATH, 0, 'MEMPATHS', & this%model_mempath) call mem_allocate(this%inunits, 0, 'INUNITS', this%model_mempath) - ! + ! build descriptions of packages call this%addpkgs() - ! - ! -- return - return end subroutine modelpkgs_init !> @brief create the package type list !< subroutine modelpkgs_create(this, ftypes) - ! -- modules use SortModule, only: qsort - ! -- dummy class(ModelPackageInputsType) :: this type(CharacterStringType), dimension(:), contiguous, & pointer :: ftypes - ! -- local integer(I4B), dimension(:), allocatable :: cunit_idxs, indx character(len=LENPACKAGETYPE) :: ftype integer(I4B) :: n, m logical(LGP) :: found - ! - ! -- allocate + + ! allocate allocate (cunit_idxs(0)) - ! - ! -- identify input packages and check that each is supported + + ! identify input packages and check that each is supported do n = 1, size(ftypes) - ! - ! -- type from model nam file packages block + ! type from model nam file packages block ftype = ftypes(n) found = .false. - ! - ! -- search supported types for this filetype + + ! search supported types for this filetype do m = 1, this%niunit if (this%cunit(m) == ftype) then - ! -- set found + ! set found found = .true. - ! - ! -- add to cunit list if first instance of this type + + ! add to cunit list if first instance of this type if (any(cunit_idxs == m)) then ! no-op else call expandarray(cunit_idxs) cunit_idxs(size(cunit_idxs)) = m end if - ! - ! -- exit search + + ! exit search exit end if end do - ! - ! -- set error if namfile pkg filetype is not supported + + ! set error if namfile pkg filetype is not supported if (.not. found) then write (errmsg, '(a,a,a,a,a)') 'Model package type not supported & &[model=', trim(this%modelname), ', type=', & @@ -336,42 +290,35 @@ subroutine modelpkgs_create(this, ftypes) call store_error_filename(this%modelfname) end if end do - ! - ! -- allocate the pkglist + + ! allocate the pkglist allocate (this%pkglist(size(cunit_idxs))) - ! - ! -- sort cunit indexes + + ! sort cunit indexes allocate (indx(size(cunit_idxs))) call qsort(indx, cunit_idxs) - ! - ! -- create sorted LoadablePackageType object list + + ! create sorted LoadablePackageType object list do n = 1, size(cunit_idxs) call this%pkglist(n)%create(this%modeltype, this%modelname, & this%cunit(cunit_idxs(n))) end do - ! - ! -- cleanup + + ! cleanup deallocate (cunit_idxs) deallocate (indx) - ! - ! -- return - return end subroutine modelpkgs_create !> @brief add a model package instance to package type list !< subroutine modelpkgs_add(this, pkgtype, filename, pkgname) - ! -- modules - ! -- dummy class(ModelPackageInputsType) :: this character(len=*), intent(in) :: pkgtype character(len=*), intent(in) :: filename character(len=*), intent(in) :: pkgname - ! -- local type(LoadablePackageType) :: pkg integer(I4B) :: n - ! - ! -- locate index of pkgtype in pkglist + ! locate index of pkgtype in pkglist do n = 1, size(this%pkglist) pkg = this%pkglist(n) if (pkg%pkgtype == pkgtype) then @@ -380,20 +327,14 @@ subroutine modelpkgs_add(this, pkgtype, filename, pkgname) exit end if end do - ! - ! -- return - return end subroutine modelpkgs_add !> @brief build the type list with all model package instances !< subroutine modelpkgs_addpkgs(this) - ! -- modules use MemoryManagerModule, only: mem_setptr use SourceCommonModule, only: inlen_check - ! -- dummy class(ModelPackageInputsType) :: this - ! -- local type(CharacterStringType), dimension(:), contiguous, & pointer :: ftypes !< file types type(CharacterStringType), dimension(:), contiguous, & @@ -402,60 +343,50 @@ subroutine modelpkgs_addpkgs(this) pointer :: pnames !< package names character(len=LINELENGTH) :: ftype, fname, pname integer(I4B) :: n - ! - ! -- set pointers to input context model package attribute arrays + + ! set pointers to input context model package attribute arrays call mem_setptr(ftypes, 'FTYPE', this%input_mempath) call mem_setptr(fnames, 'FNAME', this%input_mempath) call mem_setptr(pnames, 'PNAME', this%input_mempath) - ! - ! -- create the package list + + ! create the package list call this%create(ftypes) - ! - ! -- load model packages + + ! load model packages do n = 1, size(ftypes) - ! - ! -- attributes for this package + ! attributes for this package ftype = ftypes(n) fname = fnames(n) call inlen_check(pnames(n), pname, LENPACKAGENAME, 'PACKAGENAME') - ! - ! -- add this instance to package list + + ! add this instance to package list call this%add(ftype, fname, pname) end do - ! - ! -- terminate if errors were detected + + ! terminate if errors were detected if (count_errors() > 0) then call store_error_filename(this%modelfname) end if - ! - ! -- - return end subroutine modelpkgs_addpkgs !> @brief get package instance count and verify base or multi of each !< function modelpkgs_pkgcount(this) result(pnum) - ! -- modules - ! -- dummy class(ModelPackageInputsType) :: this - ! - ! -- return integer(I4B) :: pnum - ! -- local integer(I4B) :: n - ! - ! -- initialize + + ! initialize pnum = 0 - ! - ! -- count model package instances + + ! count model package instances do n = 1, size(this%pkglist) - ! if (multi_pkg_type(this%component_type, & this%pkglist(n)%subcomponent_type, & this%pkglist(n)%pkgtype)) then ! multiple instances ok else - ! -- set error for unexpected extra packages + ! set error for unexpected extra packages if (this%pkglist(n)%pnum > 1) then write (errmsg, '(a,a,a,a,a)') & 'Multiple instances specified for model base package type & @@ -465,33 +396,27 @@ function modelpkgs_pkgcount(this) result(pnum) call store_error_filename(this%modelfname) end if end if - ! - ! -- add to package count + + ! add to package count pnum = pnum + this%pkglist(n)%pnum end do - ! - ! -- return - return end function modelpkgs_pkgcount !> @brief load package descriptors to managed memory !< subroutine modelpkgs_memload(this) - ! -- modules use MemoryManagerModule, only: mem_reallocate - ! -- dummy class(ModelPackageInputsType) :: this - ! -- local integer(I4B) :: n, m, idx integer(I4B) :: pnum - ! - ! -- initialize load index + + ! initialize load index idx = 0 - ! - ! -- set total number of package instances + + ! set total number of package instances pnum = this%pkgcount() - ! - ! -- reallocate model input package attribute arrays + + ! reallocate model input package attribute arrays call mem_reallocate(this%pkgtypes, LENPACKAGETYPE, pnum, 'PKGTYPES', & this%model_mempath) call mem_reallocate(this%pkgnames, LENPACKAGENAME, pnum, 'PKGNAMES', & @@ -499,47 +424,34 @@ subroutine modelpkgs_memload(this) call mem_reallocate(this%mempaths, LENMEMPATH, pnum, 'MEMPATHS', & this%model_mempath) call mem_reallocate(this%inunits, pnum, 'INUNITS', this%model_mempath) - ! - ! -- load pkinfo + + ! load pkinfo do n = 1, size(this%pkglist) - ! do m = 1, this%pkglist(n)%pnum - ! -- increment index + ! increment index idx = idx + 1 - ! -- package type like 'CHD6' + ! package type like 'CHD6' this%pkgtypes(idx) = trim(this%pkglist(n)%pkgtype) - ! -- package name like 'CHD-2' + ! package name like 'CHD-2' this%pkgnames(idx) = trim(this%pkglist(n)%pkgnames(m)) - ! -- memory path like '__INPUT__/MYMODEL/CHD-2' + ! memory path like '__INPUT__/MYMODEL/CHD-2' this%mempaths(idx) = trim(this%pkglist(n)%mempaths(m)) - ! -- input file unit number + ! input file unit number this%inunits(idx) = this%pkglist(n)%inunits(m) end do end do - ! - ! -- return - return end subroutine modelpkgs_memload !> @brief deallocate object !< subroutine modelpkgs_destroy(this) - ! -- modules - ! -- dummy class(ModelPackageInputsType) :: this - ! -- local integer(I4B) :: n - ! - ! -- do n = 1, size(this%pkglist) call this%pkglist(n)%destroy() end do - ! deallocate (this%pkglist) deallocate (this%cunit) - ! - ! -- return - return end subroutine modelpkgs_destroy end module ModelPackageInputsModule diff --git a/src/Utilities/Idm/ModflowInput.f90 b/src/Utilities/Idm/ModflowInput.f90 index 4b41218bc01..ac463b6e63f 100644 --- a/src/Utilities/Idm/ModflowInput.f90 +++ b/src/Utilities/Idm/ModflowInput.f90 @@ -60,7 +60,7 @@ function getModflowInput(pkgtype, component_type, subcomponent_type, & type(ModflowInputType) :: mf6_input character(len=LENPACKAGETYPE) :: dfn_subcomponent_type - ! -- set subcomponent type + ! set subcomponent type if (present(filename)) then dfn_subcomponent_type = update_sc_type(pkgtype, filename, component_type, & subcomponent_type) @@ -68,20 +68,20 @@ function getModflowInput(pkgtype, component_type, subcomponent_type, & dfn_subcomponent_type = trim(subcomponent_type) end if - ! -- set input attributes + ! set input attributes mf6_input%pkgtype = trim(pkgtype) mf6_input%component_type = trim(component_type) mf6_input%subcomponent_type = trim(dfn_subcomponent_type) mf6_input%component_name = trim(component_name) mf6_input%subcomponent_name = trim(subcomponent_name) - ! -- set mempaths + ! set mempaths mf6_input%mempath = create_mem_path(component_name, subcomponent_name, & idm_context) mf6_input%component_mempath = create_mem_path(component=component_name, & context=idm_context) - ! -- set input definitions + ! set input definitions mf6_input%block_dfns => block_definitions(mf6_input%component_type, & mf6_input%subcomponent_type) mf6_input%aggregate_dfns => aggregate_definitions(mf6_input%component_type, & @@ -96,11 +96,8 @@ function update_sc_type(filetype, filename, component_type, subcomponent_type) & character(len=*), intent(in) :: subcomponent_type character(len=*), intent(in) :: filetype character(len=*), intent(in) :: filename - ! -- result character(len=LENPACKAGETYPE) :: sc_type - ! sc_type = subcomponent_type - ! select case (subcomponent_type) case ('RCH', 'EVT', 'SCP') sc_type = read_as_arrays(filetype, filename, component_type, & @@ -118,43 +115,36 @@ function read_as_arrays(filetype, filename, component_type, subcomponent_type) & character(len=*), intent(in) :: subcomponent_type character(len=*), intent(in) :: filetype character(len=*), intent(in) :: filename - ! -- result character(len=LENPACKAGETYPE) :: sc_type type(BlockParserType) :: parser integer(I4B) :: ierr, inunit logical(LGP) :: isfound logical(LGP) :: endOfBlock character(len=LINELENGTH) :: keyword - ! + sc_type = subcomponent_type - ! inunit = getunit() - ! call openfile(inunit, 0, trim(adjustl(filename)), filetype, & 'FORMATTED', 'SEQUENTIAL', 'OLD') - ! call parser%Initialize(inunit, 0) - ! - ! -- get options block + + ! get options block call parser%GetBlock('OPTIONS', isfound, ierr, & supportOpenClose=.true., blockRequired=.false.) - ! - ! -- parse options block if detected + + ! parse options block if detected if (isfound) then do call parser%GetNextLine(endOfBlock) - ! if (endOfBlock) exit - ! call parser%GetStringCaps(keyword) - ! if (keyword == 'READASARRAYS') then write (sc_type, '(a)') trim(subcomponent_type)//'A' exit end if end do end if - ! + call parser%clear() end function read_as_arrays diff --git a/src/Utilities/Idm/SourceCommon.f90 b/src/Utilities/Idm/SourceCommon.f90 index 8ba4529d261..f9fdaa756d5 100644 --- a/src/Utilities/Idm/SourceCommon.f90 +++ b/src/Utilities/Idm/SourceCommon.f90 @@ -33,17 +33,11 @@ module SourceCommonModule !! !< function package_source_type(sourcename) result(sourcetype) - ! -- modules use InputOutputModule, only: upcase - ! -- dummy character(len=*), intent(in) :: sourcename - ! -- result character(len=LENPACKAGENAME) :: sourcetype - ! -- local character(len=LENPACKAGENAME) :: ext - ! ext = file_ext(sourcename) - ! select case (ext) case default sourcetype = 'MF6FILE' @@ -59,19 +53,15 @@ end function package_source_type !! !< function idm_component_type(component) result(component_type) - ! -- modules use IdmDfnSelectorModule, only: idm_component - ! -- dummy character(len=*), intent(in) :: component - ! -- return character(len=LENCOMPONENTNAME) :: component_type - ! -- local integer(I4B) :: i, ilen, idx - ! - ! -- initialize + + ! initialize component_type = '' idx = 0 - ! + ilen = len_trim(component) do i = 1, ilen if (component(i:i) == '6' .or. component(i:i) == '-') then @@ -80,7 +70,7 @@ function idm_component_type(component) result(component_type) component_type(idx:idx) = component(i:i) end if end do - ! + if (.not. idm_component(component_type)) then write (errmsg, '(a)') & 'IDP input error, unrecognized component: "'//trim(component)//'"' @@ -98,23 +88,19 @@ end function idm_component_type !< function idm_subcomponent_type(component, subcomponent) & result(subcomponent_type) - ! -- modules - ! -- dummy character(len=*), intent(in) :: component !< component, e.g. GWF6 character(len=*), intent(in) :: subcomponent !< subcomponent, e.g. CHD6 - ! -- return character(len=LENCOMPONENTNAME) :: subcomponent_type - ! -- local character(len=LENCOMPONENTNAME) :: component_type integer(I4B) :: i, ilen, idx - ! - ! -- initialize + + ! initialize subcomponent_type = '' idx = 0 - ! - ! -- verify component + + ! verify component component_type = idm_component_type(component) - ! + ilen = len_trim(subcomponent) do i = 1, ilen if (subcomponent(i:i) == '6' .or. subcomponent(i:i) == '-') then @@ -134,23 +120,15 @@ end function idm_subcomponent_type !< function idm_subcomponent_name(component_type, subcomponent_type, sc_name) & result(subcomponent_name) - ! -- modules use IdmDfnSelectorModule, only: idm_multi_package - ! -- dummy character(len=*), intent(in) :: component_type character(len=*), intent(in) :: subcomponent_type character(len=*), intent(in) :: sc_name - ! -- return character(len=LENPACKAGENAME) :: subcomponent_name - ! -- local - ! subcomponent_name = '' - ! if (idm_multi_package(component_type, subcomponent_type)) then - ! subcomponent_name = sc_name else - ! subcomponent_name = subcomponent_type end if end function idm_subcomponent_name @@ -162,23 +140,15 @@ end function idm_subcomponent_name !! !< function file_ext(filename) result(ext) - ! -- modules use IdmDfnSelectorModule, only: idm_multi_package - ! -- dummy character(len=*), intent(in) :: filename - ! -- return character(len=LENPACKAGETYPE) :: ext - ! -- local integer(I4B) :: idx - ! - ! -- initialize + ! initialize ext = '' idx = 0 - ! - ! -- identify '.' character position from back of string + ! identify '.' character position from back of string idx = index(filename, '.', back=.true.) - ! - ! if (idx > 0) then ext = filename(idx + 1:len_trim(filename)) end if @@ -195,13 +165,13 @@ subroutine get_shape_from_string(shape_string, array_shape, memoryPath) integer(I4B), pointer :: int_ptr character(len=16), dimension(:), allocatable :: array_shape_string character(len=:), allocatable :: shape_string_copy - ! - ! -- parse the string into multiple words + + ! parse the string into multiple words shape_string_copy = trim(shape_string)//' ' call ParseLine(shape_string_copy, ndim, array_shape_string) allocate (array_shape(ndim)) - ! - ! -- find shape in memory manager and put into array_shape + + ! find shape in memory manager and put into array_shape do i = 1, ndim call mem_setptr(int_ptr, array_shape_string(i), memoryPath) array_shape(i) = int_ptr @@ -231,8 +201,6 @@ subroutine get_layered_shape(mshape, nlay, layer_shape) layer_shape(1) = mshape(3) ! ncol layer_shape(2) = mshape(2) ! nrow end if - - return end subroutine get_layered_shape !> @brief routine for setting the model shape @@ -257,39 +225,37 @@ subroutine set_model_shape(ftype, fname, model_mempath, dis_mempath, & integer(I4B), pointer :: ncelldim integer(I4B), pointer :: distype integer(I4B) :: dim1_size, dim2_size, dim3_size, dis_type - ! - ! -- initialize dis_type + + ! initialize dis_type dis_type = DISUNDEF - ! - ! -- allocate and set model shape in model input context + + ! allocate and set model shape in model input context select case (ftype) case ('DIS6') - ! - ! -- set dis_type + ! set dis_type dis_type = DIS - ! call get_isize('NLAY', dis_mempath, dim1_size) call get_isize('NROW', dis_mempath, dim2_size) call get_isize('NCOL', dis_mempath, dim3_size) - ! + if (dim1_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NLAY" not found.' call store_error(errmsg) end if - ! + if (dim2_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NROW" not found.' call store_error(errmsg) end if - ! + if (dim3_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NCOL" not found.' call store_error(errmsg) end if - ! + if (dim1_size >= 1 .and. dim2_size >= 1 .and. dim3_size >= 1) then call mem_allocate(model_shape, 3, 'MODEL_SHAPE', model_mempath) call mem_setptr(ndim1, 'NLAY', dis_mempath) @@ -299,27 +265,24 @@ subroutine set_model_shape(ftype, fname, model_mempath, dis_mempath, & else call store_error_filename(fname) end if - ! case ('DIS2D6') - ! - ! -- set dis_type + ! set dis_type dis_type = DIS2D - ! call get_isize('NROW', dis_mempath, dim1_size) call get_isize('NCOL', dis_mempath, dim2_size) - ! + if (dim1_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NROW" not found.' call store_error(errmsg) end if - ! + if (dim2_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NCOL" not found.' call store_error(errmsg) end if - ! + if (dim1_size >= 1 .and. dim2_size >= 1) then call mem_allocate(model_shape, 2, 'MODEL_SHAPE', model_mempath) call mem_setptr(ndim1, 'NROW', dis_mempath) @@ -328,27 +291,24 @@ subroutine set_model_shape(ftype, fname, model_mempath, dis_mempath, & else call store_error_filename(fname) end if - ! case ('DISV6') - ! - ! -- set dis_type + ! set dis_type dis_type = DISV - ! call get_isize('NLAY', dis_mempath, dim1_size) call get_isize('NCPL', dis_mempath, dim2_size) - ! + if (dim1_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NLAY" not found.' call store_error(errmsg) end if - ! + if (dim2_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NCPL" not found.' call store_error(errmsg) end if - ! + if (dim1_size >= 1 .and. dim2_size >= 1) then call mem_allocate(model_shape, 2, 'MODEL_SHAPE', model_mempath) call mem_setptr(ndim1, 'NLAY', dis_mempath) @@ -358,15 +318,14 @@ subroutine set_model_shape(ftype, fname, model_mempath, dis_mempath, & call store_error_filename(fname) end if case ('DISV2D6') - ! call get_isize('NODES', dis_mempath, dim1_size) - ! + if (dim1_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NODES" not found.' call store_error(errmsg) end if - ! + if (dim1_size >= 1) then call mem_allocate(model_shape, 1, 'MODEL_SHAPE', model_mempath) call mem_setptr(ndim1, 'NODES', dis_mempath) @@ -375,23 +334,22 @@ subroutine set_model_shape(ftype, fname, model_mempath, dis_mempath, & call store_error_filename(fname) end if case ('DISU6', 'DISV1D6') - ! - ! -- set dis_type + ! set dis_type if (ftype == 'DISU6') then dis_type = DISU else if (ftype == 'DISV1D6') then dis_type = DISV1D end if - ! + call get_isize('NODES', dis_mempath, dim1_size) - ! + if (dim1_size <= 0) then write (errmsg, '(a)') & 'Required input dimension "NODES" not found.' call store_error(errmsg) call store_error_filename(fname) end if - ! + call mem_allocate(model_shape, 1, 'MODEL_SHAPE', model_mempath) call mem_setptr(ndim1, 'NODES', dis_mempath) model_shape = [ndim1] @@ -401,33 +359,25 @@ subroutine set_model_shape(ftype, fname, model_mempath, dis_mempath, & call store_error(errmsg) call store_error_filename(fname) end select - ! - ! -- allocate and set ncelldim in model input context + + ! allocate and set ncelldim in model input context call mem_allocate(ncelldim, 'NCELLDIM', model_mempath) ncelldim = size(model_shape) - ! - ! -- allocate and set distype in model input context + + ! allocate and set distype in model input context call mem_allocate(distype, 'DISENUM', model_mempath) distype = dis_type end subroutine set_model_shape function ifind_charstr(array, str) use CharacterStringModule, only: CharacterStringType - ! -- Find the first array element containing str - ! -- Return -1 if not found. implicit none - ! -- return integer(I4B) :: ifind_charstr - ! -- dummy type(CharacterStringType), dimension(:), intent(in) :: array character(len=*) :: str character(len=LINELENGTH) :: compare_str - ! -- local integer(I4B) :: i - ! - ! -- initialize ifind_charstr = -1 - ! findloop: do i = 1, size(array) compare_str = array(i) if (compare_str == str) then @@ -459,27 +409,24 @@ function filein_fname(filename, tagname, input_mempath, input_fname) & type(CharacterStringType), dimension(:), pointer, & contiguous :: fnames integer(I4B) :: isize - ! - ! -- initialize + + ! initialize found = .false. filename = '' - ! + call get_isize(tagname, input_mempath, isize) - ! + if (isize > 0) then - ! if (isize /= 1) then errmsg = 'Multiple FILEIN keywords detected for tag "'//trim(tagname)// & '" in OPTIONS block. Only one entry allowed.' call store_error(errmsg) call store_error_filename(input_fname) end if - ! + call mem_setptr(fnames, tagname, input_mempath) - ! filename = fnames(1) found = .true. - ! end if end function filein_fname @@ -493,8 +440,8 @@ subroutine inlen_check(input_name, mf6_name, maxlen, name_type) character(len=*), intent(in) :: name_type character(len=LINELENGTH) :: input_str integer(I4B) :: ilen - ! - ! -- initialize + + ! initialize mf6_name = '' input_str = input_name ilen = len_trim(input_str) @@ -504,8 +451,8 @@ subroutine inlen_check(input_name, mf6_name, maxlen, name_type) maxlen, ') for '//trim(name_type)//'.' call store_error(errmsg) end if - ! - ! -- set truncated name + + ! set truncated name mf6_name = trim(input_str) end subroutine inlen_check diff --git a/src/Utilities/Idm/SourceLoad.F90 b/src/Utilities/Idm/SourceLoad.F90 index 3090e42232d..08a6cb90390 100644 --- a/src/Utilities/Idm/SourceLoad.F90 +++ b/src/Utilities/Idm/SourceLoad.F90 @@ -48,33 +48,28 @@ function create_input_loader(component_type, subcomponent_type, & type(ModflowInputType) :: mf6_input character(len=LENPACKAGENAME) :: source_type character(len=LENPACKAGENAME) :: sc_name - ! - ! -- set subcomponent name + + ! set subcomponent name sc_name = idm_subcomponent_name(component_type, subcomponent_type, & subcomponent_name) - ! - ! -- create description of input + ! create description of input mf6_input = getModflowInput(input_type, component_type, subcomponent_type, & component_name, sc_name, input_fname) - ! - ! -- set package source + ! set package source source_type = package_source_type(input_fname) - ! - ! -- set source loader for model package + + ! set source loader for model package loader => package_loader(source_type) - ! - ! -- initialize loader + + ! initialize loader call loader%init(mf6_input, component_name, component_fname, input_fname) - ! - ! -- initialize loader netcdf variables data structure + + ! initialize loader netcdf variables data structure if (present(nc_vars)) then call nc_vars%create_varlists(component_name, sc_name, loader%nc_vars) else call loader%nc_vars%init(component_name) end if - ! - ! -- return - return end function create_input_loader !> @brief allocate source model package static loader @@ -85,11 +80,11 @@ function package_loader(source_type) result(loader) character(len=*), intent(inout) :: source_type class(Mf6FileStaticPkgLoadType), pointer :: mf6file_loader class(StaticPkgLoadBaseType), pointer :: loader - ! - ! -- initialize + + ! initialize nullify (loader) - ! - ! -- allocate derived object + + ! allocate derived object select case (source_type) case ('MF6FILE') allocate (mf6file_loader) @@ -101,9 +96,6 @@ function package_loader(source_type) result(loader) '" not currently supported.' call store_error(errmsg, .true.) end select - ! - ! -- return - return end function package_loader function open_source_file(pkgtype, filename, modelfname, iout) result(fd) @@ -115,11 +107,11 @@ function open_source_file(pkgtype, filename, modelfname, iout) result(fd) integer(I4B), intent(in) :: iout integer(I4B) :: fd character(len=LENPACKAGENAME) :: source_type - ! - ! -- initialize + + ! initialize fd = 0 - ! - ! -- set source type + + ! set source type source_type = package_source_type(filename) ! select case (source_type) @@ -127,9 +119,6 @@ function open_source_file(pkgtype, filename, modelfname, iout) result(fd) fd = open_mf6file(pkgtype, filename, modelfname, iout) case default end select - ! - ! -- return - return end function open_source_file subroutine load_modelnam(mtype, mfname, mname, iout) @@ -142,22 +131,18 @@ subroutine load_modelnam(mtype, mfname, mname, iout) integer(I4B), intent(in) :: iout type(ModflowInputType) :: mf6_input character(len=LENPACKAGENAME) :: source_type - ! - ! -- set source type + + ! set source type source_type = package_source_type(mfname) - ! - ! -- create description of input + + ! create description of input mf6_input = getModflowInput(mtype, idm_component_type(mtype), 'NAM', & mname, 'NAM', mfname) - ! select case (source_type) case ('MF6FILE') call input_load(mfname, mf6_input, simfile, iout) case default end select - ! - ! -- return - return end subroutine load_modelnam subroutine load_simnam() @@ -169,78 +154,61 @@ subroutine load_simnam() type(ModflowInputType) :: mf6_input, hpc_input character(len=LINELENGTH) :: hpc6_filename character(len=LINELENGTH) :: line - logical :: lexist - ! - ! -- load mfsim.nam if it exists + logical(LGP) :: lexist + + ! load mfsim.nam if it exists inquire (file=trim(adjustl(simfile)), exist=lexist) - ! + if (lexist) then - ! - ! -- write name of namfile to stdout + ! write name of namfile to stdout write (line, '(2(1x,a))') 'Using Simulation name file:', & trim(adjustl(simfile)) call write_message(line, skipafter=1) - ! - ! -- create description of input + ! create description of input mf6_input = getModflowInput('NAM6', 'SIM', 'NAM', 'SIM', 'NAM', simfile) - ! - ! -- open namfile and load to input context + ! open namfile and load to input context call input_load(simfile, mf6_input, simfile, iout) - ! - ! -- load optional HPC configuration file + ! load optional HPC configuration file if (filein_fname(hpc6_filename, 'HPC6_FILENAME', mf6_input%mempath, & simfile)) then hpc_input = getModflowInput('HPC6', 'UTL', 'HPC', 'UTL', 'HPC') call input_load(hpc6_filename, hpc_input, simfile, iout) end if end if - ! - ! -- return - return end subroutine load_simnam subroutine load_simtdis() - ! -- modules use SimVariablesModule, only: simfile, iout use MemoryHelperModule, only: create_mem_path use MemoryManagerModule, only: mem_setptr use SimVariablesModule, only: idm_context use SourceCommonModule, only: package_source_type use IdmMf6FileModule, only: input_load - ! -- dummy - ! -- locals character(len=LENMEMPATH) :: input_mempath type(ModflowInputType) :: mf6_input character(len=LENPACKAGENAME) :: source_type character(len=:), pointer :: tdis6 - logical :: lexist - ! - ! -- set input memory path + logical(LGP) :: lexist + + ! set input memory path input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! - ! -- set pointers to input context timing params + + ! set pointers to input context timing params call mem_setptr(tdis6, 'TDIS6', input_mempath) - ! - ! -- create timing + + ! create timing if (tdis6 /= '') then - ! - ! -- set source type + ! set source type source_type = package_source_type(tdis6) - ! select case (source_type) case ('MF6FILE') - ! inquire (file=trim(adjustl(tdis6)), exist=lexist) - ! if (lexist) then - ! - ! -- create description of input + ! create description of input mf6_input = getModflowInput('TDIS6', 'SIM', 'TDIS', & 'SIM', 'TDIS', simfile) - ! - ! -- open namfile and load to input context + ! open namfile and load to input context call input_load(tdis6, mf6_input, simfile, iout) - ! else write (errmsg, '(a)') & 'Simulation TIMING input file "'//trim(tdis6)// & @@ -251,9 +219,6 @@ subroutine load_simtdis() case default end select end if - ! - ! -- return - return end subroutine load_simtdis function remote_model_ndim(mtype, mfname) result(ncelldim) @@ -269,46 +234,40 @@ function remote_model_ndim(mtype, mfname) result(ncelldim) integer(I4B) :: ierr, inunit logical(LGP) :: isfound, endOfBlock character(len=LINELENGTH) :: ptype - ! - ! -- initialize + + ! initialize ncelldim = 0 - ! - ! -- set source type + + ! set source type source_type = package_source_type(mfname) - ! select case (source_type) case ('MF6FILE') - ! - ! -- open name file + ! open name file inunit = getunit() call openfile(inunit, 0, trim(adjustl(mfname)), mtype, & 'FORMATTED', 'SEQUENTIAL', 'OLD') - ! - ! -- initialize parser + ! initialize parser call parser%Initialize(inunit, 0) - ! - ! -- get options block + ! get options block call parser%GetBlock('OPTIONS', isfound, ierr, & supportOpenClose=.true., blockRequired=.false.) - ! -- iterate through options + ! iterate through options if (isfound) then do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit end do end if - ! - ! -- get packages block + ! get packages block call parser%GetBlock('PACKAGES', isfound, ierr, & supportOpenClose=.true., blockRequired=.true.) if (isfound) then - ! -- read through packages + ! read through packages do call parser%GetNextLine(endOfBlock) if (endOfBlock) exit - ! call parser%GetStringCaps(ptype) - ! + select case (ptype) case ('DIS6') ncelldim = 3 @@ -330,27 +289,21 @@ function remote_model_ndim(mtype, mfname) result(ncelldim) end select end do end if - ! + call parser%clear() - ! case default end select - ! - ! -- return - return end function remote_model_ndim !> @brief create model exports list !< subroutine export_cr() - ! -- modules use ModelExportModule, only: modelexports_create, nc_export_active #if defined(__WITH_NETCDF__) use NCExportCreateModule, only: nc_export_create #endif call modelexports_create(iout) - ! - ! -- are netcdf exports elected + ! are netcdf exports elected if (nc_export_active()) then #if defined(__WITH_NETCDF__) call nc_export_create() @@ -366,7 +319,6 @@ end subroutine export_cr !> @brief model exports post prepare step actions !< subroutine export_post_prepare() - ! -- modules use ModelExportModule, only: modelexports_post_prepare call modelexports_post_prepare() end subroutine export_post_prepare @@ -374,7 +326,6 @@ end subroutine export_post_prepare !> @brief model exports post step actions !< subroutine export_post_step() - ! -- modules use ModelExportModule, only: modelexports_post_step call modelexports_post_step() end subroutine export_post_step @@ -382,7 +333,6 @@ end subroutine export_post_step !> @brief deallocate model export objects and list !< subroutine export_da() - ! -- modules use ModelExportModule, only: modelexports_destroy call modelexports_destroy() end subroutine export_da @@ -395,14 +345,11 @@ subroutine nc_close(ncid, nc_fname) #endif integer(I4B), intent(in) :: ncid character(len=*), intent(in) :: nc_fname - ! if (ncid > 0) then #if defined(__WITH_NETCDF__) call nc_fclose(ncid, nc_fname) #endif end if - ! - return end subroutine nc_close !> @brief create model netcdf context @@ -415,36 +362,30 @@ function netcdf_context(modeltype, component_type, modelname, & #if defined(__WITH_NETCDF__) use NCContextBuildModule, only: open_ncfile, create_netcdf_context #endif - ! -- dummy character(len=*), intent(in) :: modeltype character(len=*), intent(in) :: component_type character(len=*), intent(in) :: modelname character(len=*), intent(in) :: modelfname integer(I4B), intent(in) :: iout - ! -- return type(NCFileVarsType), pointer :: nc_vars - ! -- local character(len=LENMEMPATH) :: input_mempath character(len=LINELENGTH) :: nc_fname integer(I4B) :: ncid - ! - ! -- set input memory path + + ! set input memory path input_mempath = create_mem_path(modelname, 'NAM', idm_context) - ! - ! -- allocate context object + + ! allocate context object allocate (nc_vars) - ! - ! -- check if optional netcdf input file was provided + + ! check if optional netcdf input file was provided if (filein_fname(nc_fname, 'NETCDF_FNAME', input_mempath, modelfname)) then #if defined(__WITH_NETCDF__) - ! - ! -- open nc input file + ! open nc input file ncid = open_ncfile(nc_fname, iout) - ! - ! -- read the file and build the context + ! read the file and build the context call create_netcdf_context(modeltype, modelname, modelfname, & nc_vars, nc_fname, ncid, iout) - ! #else write (errmsg, '(a)') & 'Cannot load model packages. NetCDF & @@ -457,9 +398,6 @@ function netcdf_context(modeltype, component_type, modelname, & ncid = 0 call nc_vars%init(modelname, '', ncid, '') end if - ! - ! -- return - return end function netcdf_context end module SourceLoadModule diff --git a/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 b/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 index a177f9495b8..360fcd47701 100644 --- a/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 +++ b/src/Utilities/Idm/mf6blockfile/IdmMf6File.f90 @@ -66,27 +66,27 @@ subroutine input_load(filename, mf6_input, component_filename, iout, nc_vars) type(NCPackageVarsType), pointer :: netcdf_vars type(LoadMf6FileType) :: loader integer(I4B) :: inunit - ! + if (present(nc_vars)) then netcdf_vars => nc_vars else nullify (netcdf_vars) end if - ! - ! -- open input file + + ! open input file inunit = open_mf6file(mf6_input%pkgtype, filename, component_filename, iout) - ! - ! -- allocate and initialize parser + + ! allocate and initialize parser allocate (parser) call parser%Initialize(inunit, iout) - ! - ! -- invoke the load routine + + ! invoke the load routine call loader%load(parser, mf6_input, netcdf_vars, filename, iout) - ! - ! -- clear parser file handles + + ! clear parser file handles call parser%clear() - ! - ! -- cleanup + + ! cleanup deallocate (parser) end subroutine input_load @@ -99,11 +99,9 @@ subroutine static_init(this, mf6_input, component_name, component_input_name, & character(len=*), intent(in) :: component_name character(len=*), intent(in) :: component_input_name character(len=*), intent(in) :: input_name - ! - ! -- initialize base type + ! initialize base type call this%StaticPkgLoadType%init(mf6_input, component_name, & component_input_name, input_name) - ! end subroutine static_init !> @brief load routine for static loader @@ -113,33 +111,26 @@ function static_load(this, iout) result(rp_loader) integer(I4B), intent(in) :: iout class(DynamicPkgLoadBaseType), pointer :: rp_loader class(Mf6FileDynamicPkgLoadType), pointer :: mf6_loader - ! - ! -- initialize return pointer + + ! initialize return pointer nullify (rp_loader) - ! - ! -- load model package to input context + + ! load model package to input context if (this%iperblock > 0) then - ! - ! -- allocate dynamic loader + ! allocate dynamic loader allocate (mf6_loader) - ! - ! -- point to nc_vars structure + ! point to nc_vars structure mf6_loader%nc_vars => this%nc_vars - ! - ! -- nullify nc_vars pointer so it isn't deallocated + ! nullify nc_vars pointer so it isn't deallocated nullify (this%nc_vars) - ! - ! -- initialize dynamic loader + ! initialize dynamic loader call mf6_loader%init(this%mf6_input, this%component_name, & this%component_input_name, this%input_name, & this%iperblock, iout) - ! - ! -- set return pointer to base dynamic loader + ! set return pointer to base dynamic loader rp_loader => mf6_loader - ! else - ! - ! -- load static input + ! load static input call input_load(this%input_name, this%mf6_input, & this%component_input_name, iout, this%nc_vars) end if @@ -149,10 +140,8 @@ end function static_load !< subroutine static_destroy(this) class(Mf6FileStaticPkgLoadType), intent(inout) :: this - ! - ! -- deallocate base type + ! deallocate base type call this%StaticPkgLoadType%destroy() - ! end subroutine static_destroy !> @brief dynamic loader init @@ -170,29 +159,28 @@ subroutine dynamic_init(this, mf6_input, component_name, component_input_name, & integer(I4B), intent(in) :: iperblock integer(I4B), intent(in) :: iout integer(I4B) :: inunit - ! - ! -- initialize base loader + + ! initialize base loader call this%DynamicPkgLoadType%init(mf6_input, component_name, & component_input_name, input_name, & iperblock, iout) - ! - ! -- allocate scalars + ! allocate scalars call mem_allocate(this%iper, 'IPER', mf6_input%mempath) call mem_allocate(this%ionper, 'IONPER', mf6_input%mempath) - ! - ! -- initialize + + ! initialize this%iper = 0 this%ionper = 0 - ! - ! -- open input file + + ! open input file inunit = open_mf6file(mf6_input%pkgtype, input_name, & component_input_name, iout) - ! - ! -- allocate and initialize parser + + ! allocate and initialize parser allocate (this%parser) call this%parser%Initialize(inunit, iout) - ! - ! -- allocate and initialize loader + + ! allocate and initialize loader call this%create_loader() end subroutine dynamic_init @@ -200,11 +188,9 @@ end subroutine dynamic_init !< subroutine dynamic_df(this) class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! - ! -- invoke loader define + ! invoke loader define call this%rp_loader%df() - ! - ! -- read first ionper + ! read first ionper call this%read_ionper() end subroutine dynamic_df @@ -212,30 +198,26 @@ end subroutine dynamic_df !< subroutine dynamic_ad(this) class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! - ! -- invoke loader advance + ! invoke loader advance call this%rp_loader%ad() end subroutine dynamic_ad !> @brief read and prepare routine for dynamic loader !< subroutine dynamic_rp(this) - ! -- modules use TdisModule, only: kper, nper - ! -- dummy class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! -- local - ! - ! -- check if ready to load + + ! check if ready to load if (this%ionper /= kper) return - ! - ! -- dynamic load + + ! dynamic load call this%rp_loader%rp(this%parser) - ! - ! -- update loaded iper + + ! update loaded iper this%iper = kper - ! - ! -- read next iper + + ! read next iper if (kper < nper) then call this%read_ionper() else @@ -246,26 +228,20 @@ end subroutine dynamic_rp !> @brief dynamic loader read ionper of next period block !< subroutine dynamic_read_ionper(this) - ! -- modules use TdisModule, only: kper, nper - ! -- dummy class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! -- local character(len=LINELENGTH) :: line logical(LGP) :: isblockfound integer(I4B) :: ierr character(len=*), parameter :: fmtblkerr = & &"('Looking for BEGIN PERIOD iper. Found ', a, ' instead.')" - ! + call this%parser%GetBlock('PERIOD', isblockfound, ierr, & supportOpenClose=.true., & blockRequired=.false.) - ! - ! -- set first period block IPER + ! set first period block IPER if (isblockfound) then - ! this%ionper = this%parser%GetInteger() - ! if (this%ionper <= this%iper) then write (errmsg, '(a, i0, a, i0, a, i0, a)') & 'Error in stress period ', kper, & @@ -274,15 +250,13 @@ subroutine dynamic_read_ionper(this) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - ! else - ! - ! -- PERIOD block not found + ! PERIOD block not found if (ierr < 0) then - ! -- End of file found; data applies for remainder of simulation. + ! End of file found; data applies for remainder of simulation. this%ionper = nper + 1 else - ! -- Found invalid block + ! Found invalid block call this%parser%GetCurrentLine(line) write (errmsg, fmtblkerr) adjustl(trim(line)) call store_error(errmsg) @@ -297,13 +271,12 @@ subroutine dynamic_create_loader(this) use Mf6FileGridInputModule, only: BoundGridInputType use Mf6FileListInputModule, only: BoundListInputType use Mf6FileStoInputModule, only: StoInputType - ! -- dummy class(Mf6FileDynamicPkgLoadType), intent(inout) :: this class(BoundListInputType), pointer :: bndlist_loader class(BoundGridInputType), pointer :: bndgrid_loader class(StoInputType), pointer :: sto_loader - ! - ! -- allocate and set loader + + ! allocate and set loader if (this%mf6_input%subcomponent_type == 'STO') then allocate (sto_loader) this%rp_loader => sto_loader @@ -314,11 +287,11 @@ subroutine dynamic_create_loader(this) allocate (bndlist_loader) this%rp_loader => bndlist_loader end if - ! - ! -- set nc_vars pointer + + ! set nc_vars pointer this%rp_loader%nc_vars => this%nc_vars - ! - ! -- initialize loader + + ! initialize loader call this%rp_loader%ainit(this%mf6_input, & this%component_name, & this%component_input_name, & @@ -333,44 +306,39 @@ end subroutine dynamic_create_loader subroutine dynamic_destroy(this) use MemoryManagerModule, only: mem_deallocate class(Mf6FileDynamicPkgLoadType), intent(inout) :: this - ! - ! -- deallocate scalars + + ! deallocate scalars call mem_deallocate(this%iper) call mem_deallocate(this%ionper) - ! - ! -- deallocate loader + + ! deallocate loader nullify (this%rp_loader%nc_vars) call this%rp_loader%destroy() deallocate (this%rp_loader) - ! - ! -- deallocate parser + + ! deallocate parser call this%parser%clear() deallocate (this%parser) - ! - ! -- deallocate input context + + ! deallocate input context call this%DynamicPkgLoadType%destroy() end subroutine dynamic_destroy !> @brief open a model package files !< function open_mf6file(filetype, filename, component_fname, iout) result(inunit) - ! -- modules use InputOutputModule, only: openfile, getunit - ! -- dummy character(len=*), intent(in) :: filetype character(len=*), intent(in) :: filename character(len=*), intent(in) :: component_fname integer(I4B), intent(in) :: iout - ! -- return integer(I4B) :: inunit - ! -- local - ! - ! -- initialize + + ! initialize inunit = 0 - ! + if (filename /= '') then - ! - ! -- get unit number and open file + ! get unit number and open file inunit = getunit() call openfile(inunit, iout, trim(adjustl(filename)), filetype, & 'FORMATTED', 'SEQUENTIAL', 'OLD') diff --git a/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 b/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 index c4698340a31..5545e03ed54 100644 --- a/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 +++ b/src/Utilities/Idm/mf6blockfile/LoadMf6File.f90 @@ -82,35 +82,30 @@ module LoadMf6FileModule !! !< subroutine load(this, parser, mf6_input, nc_vars, filename, iout) - ! -- modules use MemoryManagerModule, only: get_isize - ! -- dummy class(LoadMf6FileType) :: this type(BlockParserType), target, intent(inout) :: parser type(ModflowInputType), intent(in) :: mf6_input type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: filename integer(I4B), intent(in) :: iout - ! -- local integer(I4B) :: iblk - ! - ! -- initialize static load + + ! initialize static load call this%init(parser, mf6_input, filename, iout) - ! + + ! set netcdf vars this%nc_vars => nc_vars - ! - ! -- process blocks + + ! process blocks do iblk = 1, size(this%mf6_input%block_dfns) - ! - ! -- don't load dynamic input data + ! don't load dynamic input data if (this%mf6_input%block_dfns(iblk)%blockname == 'PERIOD') exit - ! - ! -- load the block + ! load the block call this%load_block(iblk) - ! end do - ! - ! -- finalize static load + + ! finalize static load call this%finalize() end subroutine load @@ -120,17 +115,14 @@ end subroutine load !! !< subroutine init(this, parser, mf6_input, filename, iout) - ! -- modules use MemoryManagerModule, only: get_isize - ! -- dummy class(LoadMf6FileType) :: this type(BlockParserType), target, intent(inout) :: parser type(ModflowInputType), intent(in) :: mf6_input character(len=*), intent(in) :: filename integer(I4B), intent(in) :: iout - ! -- local integer(I4B) :: isize - ! + this%parser => parser this%mf6_input = mf6_input this%filename = filename @@ -140,14 +132,13 @@ subroutine init(this, parser, mf6_input, filename, iout) this%inamedbound = 0 this%iauxiliary = 0 this%iout = iout - ! + call get_isize('MODEL_SHAPE', mf6_input%component_mempath, isize) - ! if (isize > 0) then call mem_setptr(this%mshape, 'MODEL_SHAPE', mf6_input%component_mempath) end if - ! - ! -- log lst file header + + ! log lst file header call idm_log_header(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) end subroutine init @@ -161,27 +152,22 @@ end subroutine init !! !< subroutine load_block(this, iblk) - ! -- modules use StructArrayModule, only: destructStructArray - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk - ! -- local - ! - ! -- reset structarray if it was created for previous block + + ! reset structarray if it was created for previous block if (associated(this%structarray)) then - ! -- destroy the structured array reader + ! destroy the structured array reader call destructStructArray(this%structarray) end if - ! + allocate (this%block_tags(0)) - ! - ! -- load the block + ! load the block call this%parse_block(iblk, .false.) - ! - ! -- post process block + ! post process block call this%block_post_process(iblk) - ! + ! cleanup deallocate (this%block_tags) end subroutine load_block @@ -191,19 +177,14 @@ end subroutine load_block !! !< subroutine finalize(this) - ! -- modules use StructArrayModule, only: destructStructArray - ! -- dummy class(LoadMf6FileType) :: this - ! -- local - ! - ! -- cleanup + ! cleanup if (associated(this%structarray)) then - ! -- destroy the structured array reader + ! destroy the structured array reader call destructStructArray(this%structarray) end if - ! - ! -- close logging block + ! close logging block call idm_log_close(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) end subroutine finalize @@ -212,19 +193,16 @@ end subroutine finalize !! !< subroutine block_post_process(this, iblk) - ! -- modules use ConstantsModule, only: LENBOUNDNAME use CharacterStringModule, only: CharacterStringType use SourceCommonModule, only: set_model_shape - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iparam integer(I4B), pointer :: intptr - ! - ! -- update state based on read tags + + ! update state based on read tags do iparam = 1, size(this%block_tags) select case (this%mf6_input%block_dfns(iblk)%blockname) case ('OPTIONS') @@ -242,14 +220,13 @@ subroutine block_post_process(this, iblk) case default end select end do - ! - ! -- update input context allocations based on dfn set and input + + ! update input context allocations based on dfn set and input select case (this%mf6_input%block_dfns(iblk)%blockname) case ('OPTIONS') - ! -- allocate naux and set to 0 if not allocated + ! allocate naux and set to 0 if not allocated do iparam = 1, size(this%mf6_input%param_dfns) idt => this%mf6_input%param_dfns(iparam) - ! if (idt%blockname == 'OPTIONS' .and. & idt%tagname == 'AUXILIARY') then if (this%iauxiliary == 0) then @@ -260,7 +237,7 @@ subroutine block_post_process(this, iblk) end if end do case ('DIMENSIONS') - ! -- set model shape if discretization dimensions have been read + ! set model shape if discretization dimensions have been read if (this%mf6_input%pkgtype(1:3) == 'DIS') then call set_model_shape(this%mf6_input%pkgtype, this%filename, & this%mf6_input%component_mempath, & @@ -274,22 +251,19 @@ end subroutine block_post_process !! !< recursive subroutine parse_block(this, iblk, recursive_call) - ! -- modules use MemoryTypeModule, only: MemoryType use MemoryManagerModule, only: get_from_memorystore - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk logical(LGP), intent(in) :: recursive_call !< true if recursive call - ! -- local logical(LGP) :: isblockfound logical(LGP) :: endOfBlock logical(LGP) :: supportOpenClose integer(I4B) :: ierr logical(LGP) :: found, required type(MemoryType), pointer :: mt - ! - ! -- disu vertices/cell2d blocks are contingent on NVERT dimension + + ! disu vertices/cell2d blocks are contingent on NVERT dimension if (this%mf6_input%pkgtype == 'DISU6' .or. & this%mf6_input%pkgtype == 'DISV1D6' .or. & this%mf6_input%pkgtype == 'DISV2D6') then @@ -301,38 +275,33 @@ recursive subroutine parse_block(this, iblk, recursive_call) if (mt%intsclr == 0) return end if end if - ! - ! -- block open/close support + + ! block open/close support supportOpenClose = (this%mf6_input%block_dfns(iblk)%blockname /= 'GRIDDATA') - ! - ! -- parser search for block + + ! parser search for block required = this%mf6_input%block_dfns(iblk)%required .and. .not. recursive_call call this%parser%GetBlock(this%mf6_input%block_dfns(iblk)%blockname, & isblockfound, ierr, & supportOpenClose=supportOpenClose, & blockRequired=required) - ! - ! -- process block + ! process block if (isblockfound) then if (this%mf6_input%block_dfns(iblk)%aggregate) then - ! - ! -- process block recarray type, set of variable 1d/2d types + ! process block recarray type, set of variable 1d/2d types call this%parse_structarray_block(iblk) - ! else do ! process each line in block call this%parser%GetNextLine(endOfBlock) if (endOfBlock) exit - ! - ! -- process line as tag(s) + ! process line as tag(s) call this%parse_tag(iblk, .false.) - ! end do end if end if - ! - ! -- recurse if block is reloadable and was just read + + ! recurse if block is reloadable and was just read if (this%mf6_input%block_dfns(iblk)%block_variable) then if (isblockfound) then call this%parse_block(iblk, .true.) @@ -341,64 +310,51 @@ recursive subroutine parse_block(this, iblk, recursive_call) end subroutine parse_block subroutine parse_io_tag(this, iblk, pkgtype, which, tag) - ! -- modules - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk character(len=*), intent(in) :: pkgtype character(len=*), intent(in) :: which character(len=*), intent(in) :: tag - ! -- local type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record - ! - ! -- matches, read and load file name + ! matches, read and load file name idt => & get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & this%mf6_input%block_dfns(iblk)%blockname, & tag, this%filename) - ! - ! -- load io tag + ! load io tag call load_io_tag(this%parser, idt, this%mf6_input%mempath, which, this%iout) end subroutine parse_io_tag subroutine parse_keyword_tag(this, iblk, tag, idt) - ! -- modules use DefinitionSelectModule, only: split_record_definition - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk character(len=LINELENGTH), intent(in) :: tag type(InputParamDefinitionType), pointer, intent(in) :: idt - ! -- local character(len=40), dimension(:), allocatable :: words integer(I4B) :: nwords character(len=LINELENGTH) :: io_tag logical(LGP) :: found - ! - ! -- initialization + + ! initialization found = .false. - ! - ! -- if in record tag check and load if input/output file + + ! if in record tag check and load if input/output file if (idt%in_record) then - ! - ! -- get tokens in matching definition + ! get tokens in matching definition call split_record_definition(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & tag, nwords, words) - ! - ! -- a filein/fileout record tag definition has 4 tokens + ! a filein/fileout record tag definition has 4 tokens if (nwords == 4) then - ! - ! -- verify third definition token is FILEIN/FILEOUT + ! verify third definition token is FILEIN/FILEOUT if (words(3) == 'FILEIN' .or. words(3) == 'FILEOUT') then - ! - ! -- read 3rd token + ! read 3rd token call this%parser%GetStringCaps(io_tag) - ! - ! -- check if 3rd token matches definition + ! check if 3rd token matches definition if (io_tag == words(3)) then call this%parse_io_tag(iblk, words(2), words(3), words(4)) found = .true. @@ -408,19 +364,17 @@ subroutine parse_keyword_tag(this, iblk, tag, idt) call store_error(errmsg) call this%parser%StoreErrorUnit() end if - ! end if end if - ! - ! -- deallocate words + + ! deallocate words if (allocated(words)) deallocate (words) end if - ! + if (.not. found) then - ! -- load standard keyword tag + ! load standard keyword tag call load_keyword_type(this%parser, idt, this%mf6_input%mempath, this%iout) - ! - ! -- check/set as dev option + ! check/set as dev option if (idt%tagname(1:4) == 'DEV_' .and. & this%mf6_input%block_dfns(iblk)%blockname == 'OPTIONS') then call this%parser%DevOpt() @@ -436,17 +390,14 @@ end subroutine parse_keyword_tag !! !< recursive subroutine parse_tag(this, iblk, recursive_call) - ! -- modules use ArrayHandlersModule, only: expandarray - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk logical(LGP), intent(in) :: recursive_call !< true if recursive call - ! -- local character(len=LINELENGTH) :: tag type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record - ! - ! -- read tag name + + ! read tag name call this%parser%GetStringCaps(tag) if (recursive_call) then if (tag == '') then @@ -454,15 +405,15 @@ recursive subroutine parse_tag(this, iblk, recursive_call) return end if end if - ! - ! -- find keyword in input definition + + ! find keyword in input definition idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & this%mf6_input%block_dfns(iblk)%blockname, & tag, this%filename) - ! - ! -- allocate and load data type + + ! allocate and load data type select case (idt%datatype) case ('KEYWORD') call this%parse_keyword_tag(iblk, tag, idt) @@ -503,33 +454,28 @@ recursive subroutine parse_tag(this, iblk, recursive_call) call store_error(errmsg) call this%parser%StoreErrorUnit() end select - ! - ! -- continue line if in same record + + ! continue line if in same record if (idt%in_record) then - ! ! recursively call parse tag again to read rest of line call this%parse_tag(iblk, .true.) end if - ! - ! + call expandarray(this%block_tags) this%block_tags(size(this%block_tags)) = trim(idt%tagname) end subroutine parse_tag function block_index_dfn(this, iblk) result(idt) - ! -- modules - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk - ! -- local type(InputParamDefinitionType) :: idt !< input data type object describing this record character(len=LENVARNAME) :: varname integer(I4B) :: ilen character(len=3) :: block_suffix = 'NUM' - ! - ! -- assign first column as the block number + + ! assign first column as the block number ilen = len_trim(this%mf6_input%block_dfns(iblk)%blockname) - ! + if (ilen > (LENVARNAME - len(block_suffix))) then varname = & this%mf6_input%block_dfns(iblk)% & @@ -537,7 +483,7 @@ function block_index_dfn(this, iblk) result(idt) else varname = trim(this%mf6_input%block_dfns(iblk)%blockname)//block_suffix end if - ! + idt%component_type = trim(this%mf6_input%component_type) idt%subcomponent_type = trim(this%mf6_input%subcomponent_type) idt%blockname = trim(this%mf6_input%block_dfns(iblk)%blockname) @@ -555,13 +501,10 @@ end function block_index_dfn !! !< subroutine parse_structarray_block(this, iblk) - ! -- modules use StructArrayModule, only: StructArrayType, constructStructArray use DynamicPackageParamsModule, only: DynamicPackageParamsType - ! -- dummy class(LoadMf6FileType) :: this integer(I4B), intent(in) :: iblk - ! -- local type(DynamicPackageParamsType) :: block_params type(InputParamDefinitionType), pointer :: idt !< input data type object describing this record type(InputParamDefinitionType), target :: blockvar_idt @@ -571,101 +514,83 @@ subroutine parse_structarray_block(this, iblk) integer(I4B) :: ibinary, oc_inunit integer(I4B) :: icol, iparam integer(I4B) :: ncol - ! - ! -- initialize package params object + + ! initialize package params object call block_params%init(this%mf6_input, & this%mf6_input%block_dfns(iblk)%blockname, & this%readasarrays, this%iauxiliary, this%inamedbound) - ! - ! -- set input definition for this block + ! set input definition for this block idt => & get_aggregate_definition_type(this%mf6_input%aggregate_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & this%mf6_input%block_dfns(iblk)%blockname) - ! - ! -- if block is reloadable read the block number + ! if block is reloadable read the block number if (this%mf6_input%block_dfns(iblk)%block_variable) then blocknum = this%parser%GetInteger() else blocknum = 0 end if - ! - ! -- set ncol + + ! set ncol ncol = block_params%nparam - ! - ! -- add col if block is reloadable + ! add col if block is reloadable if (blocknum > 0) ncol = ncol + 1 - ! - ! -- use shape to set the max num of rows + ! use shape to set the max num of rows if (idt%shape /= '') then call mem_setptr(nrow, idt%shape, this%mf6_input%mempath) nrows = nrow else nrows = -1 end if - ! - ! -- create a structured array + + ! create a structured array this%structarray => constructStructArray(this%mf6_input, ncol, nrows, & blocknum, this%mf6_input%mempath, & this%mf6_input%component_mempath) - ! - ! -- create structarray vectors for each column + ! create structarray vectors for each column do icol = 1, ncol - ! - ! -- if block is reloadable, block number is first column + ! if block is reloadable, block number is first column if (blocknum > 0) then if (icol == 1) then - ! blockvar_idt = this%block_index_dfn(iblk) idt => blockvar_idt - ! call this%structarray%mem_create_vector(icol, idt) - ! - ! -- continue as this column managed by internally SA object + ! continue as this column managed by internally SA object cycle end if - ! - ! -- set indexes (where first column is blocknum) + ! set indexes (where first column is blocknum) iparam = icol - 1 else - ! - ! -- set indexes (no blocknum column) + ! set indexes (no blocknum column) iparam = icol end if - ! - ! -- set pointer to input definition for this 1d vector + ! set pointer to input definition for this 1d vector idt => & get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & this%mf6_input%block_dfns(iblk)%blockname, & block_params%params(iparam), this%filename) - ! - ! -- allocate variable in memory manager + ! allocate variable in memory manager call this%structarray%mem_create_vector(icol, idt) end do - ! - ! -- read the block control record + + ! read the block control record ibinary = read_control_record(this%parser, oc_inunit, this%iout) - ! + if (ibinary == 1) then - ! - ! -- read from binary + ! read from binary nrowsread = this%structarray%read_from_binary(oc_inunit, this%iout) - ! call this%parser%terminateblock() - ! close (oc_inunit) - ! else - ! - ! -- read from ascii + ! read from ascii nrowsread = this%structarray%read_from_parser(this%parser, this%ts_active, & this%iout) end if - ! - ! -- clean up + + ! clean up call block_params%destroy() end subroutine parse_structarray_block @@ -680,7 +605,6 @@ subroutine load_keyword_type(parser, idt, memoryPath, iout) call mem_allocate(intvar, idt%mf6varname, memoryPath) intvar = 1 call idm_log_var(intvar, idt%tagname, memoryPath, idt%datatype, iout) - return end subroutine load_keyword_type !> @brief load type string @@ -706,7 +630,6 @@ subroutine load_string_type(parser, idt, memoryPath, iout) call parser%GetString(cstr, (.not. idt%preserve_case)) call idm_log_var(cstr, idt%tagname, memoryPath, iout) end select - return end subroutine load_string_type !> @brief load io tag @@ -740,7 +663,6 @@ subroutine load_io_tag(parser, idt, memoryPath, which, iout) else if (which == 'FILEOUT') then call load_string_type(parser, idt, memoryPath, iout) end if - return end subroutine load_io_tag !> @brief load aux variable names @@ -776,7 +698,6 @@ subroutine load_auxvar_names(parser, idt, memoryPath, iout) end do deallocate (line) deallocate (caux) - return end subroutine load_auxvar_names !> @brief load type integer @@ -790,7 +711,6 @@ subroutine load_integer_type(parser, idt, memoryPath, iout) call mem_allocate(intvar, idt%mf6varname, memoryPath) intvar = parser%GetInteger() call idm_log_var(intvar, idt%tagname, memoryPath, idt%datatype, iout) - return end subroutine load_integer_type !> @brief load type 1d integer @@ -850,8 +770,6 @@ subroutine load_integer1d_type(parser, idt, mf6_input, mshape, export, & call idm_export(int1d, idt%tagname, mf6_input%mempath, idt%shape, iout) end if end if - - return end subroutine load_integer1d_type !> @brief load type 2d integer @@ -908,8 +826,6 @@ subroutine load_integer2d_type(parser, idt, mf6_input, mshape, export, & call idm_export(int2d, idt%tagname, mf6_input%mempath, idt%shape, iout) end if end if - - return end subroutine load_integer2d_type !> @brief load type 3d integer @@ -971,8 +887,6 @@ subroutine load_integer3d_type(parser, idt, mf6_input, mshape, export, & call idm_export(int3d, idt%tagname, mf6_input%mempath, idt%shape, iout) end if end if - - return end subroutine load_integer3d_type !> @brief load type double @@ -986,7 +900,6 @@ subroutine load_double_type(parser, idt, memoryPath, iout) call mem_allocate(dblvar, idt%mf6varname, memoryPath) dblvar = parser%GetDouble() call idm_log_var(dblvar, idt%tagname, memoryPath, iout) - return end subroutine load_double_type !> @brief load type 1d double @@ -1045,8 +958,6 @@ subroutine load_double1d_type(parser, idt, mf6_input, mshape, export, & call idm_export(dbl1d, idt%tagname, mf6_input%mempath, idt%shape, iout) end if end if - - return end subroutine load_double1d_type !> @brief load type 2d double @@ -1103,8 +1014,6 @@ subroutine load_double2d_type(parser, idt, mf6_input, mshape, export, & call idm_export(dbl2d, idt%tagname, mf6_input%mempath, idt%shape, iout) end if end if - - return end subroutine load_double2d_type !> @brief load type 3d double @@ -1166,87 +1075,72 @@ subroutine load_double3d_type(parser, idt, mf6_input, mshape, export, & call idm_export(dbl3d, idt%tagname, mf6_input%mempath, idt%shape, iout) end if end if - - return end subroutine load_double3d_type function read_control_record(parser, oc_inunit, iout) result(ibinary) - ! -- modules use SimModule, only: store_error_unit use InputOutputModule, only: urword use InputOutputModule, only: openfile use OpenSpecModule, only: form, access use ConstantsModule, only: LINELENGTH use BlockParserModule, only: BlockParserType - ! -- dummy type(BlockParserType), intent(inout) :: parser integer(I4B), intent(inout) :: oc_inunit integer(I4B), intent(in) :: iout - ! -- return integer(I4B) :: ibinary - ! -- local integer(I4B) :: lloc, istart, istop, idum, inunit, itmp, ierr integer(I4B) :: nunopn = 99 character(len=:), allocatable :: line character(len=LINELENGTH) :: fname - logical :: exists + logical(LGP) :: exists real(DP) :: r - ! -- formats character(len=*), parameter :: fmtocne = & &"('Specified OPEN/CLOSE file ',(A),' does not exist')" character(len=*), parameter :: fmtobf = & &"(1X,/1X,'OPENING BINARY FILE ON UNIT ',I0,':',/1X,A)" - ! - ! -- initialize oc_inunit and ibinary + + ! initialize oc_inunit and ibinary oc_inunit = 0 ibinary = 0 - ! inunit = parser%getunit() - ! - ! -- Read to the first non-commented line + + ! Read to the first non-commented line lloc = 1 call parser%line_reader%rdcom(inunit, iout, line, ierr) call urword(line, lloc, istart, istop, 1, idum, r, iout, inunit) - ! + if (line(istart:istop) == 'OPEN/CLOSE') then - ! - ! -- get filename + ! get filename call urword(line, lloc, istart, istop, 0, idum, r, & iout, inunit) - ! fname = line(istart:istop) - ! - ! -- check to see if file OPEN/CLOSE file exists + ! check to see if file OPEN/CLOSE file exists inquire (file=fname, exist=exists) - ! if (.not. exists) then write (errmsg, fmtocne) line(istart:istop) call store_error(errmsg) call store_error('Specified OPEN/CLOSE file does not exist') call store_error_unit(inunit) end if - ! - ! -- Check for (BINARY) keyword + + ! Check for (BINARY) keyword call urword(line, lloc, istart, istop, 1, idum, r, & iout, inunit) - ! + if (line(istart:istop) == '(BINARY)') ibinary = 1 - ! - ! -- Open the file depending on ibinary flag + ! Open the file depending on ibinary flag if (ibinary == 1) then oc_inunit = nunopn itmp = iout - ! if (iout > 0) then itmp = 0 write (iout, fmtobf) oc_inunit, trim(adjustl(fname)) end if - ! call openfile(oc_inunit, itmp, fname, 'OPEN/CLOSE', & fmtarg_opt=form, accarg_opt=access) end if end if - ! + if (ibinary == 0) then call parser%line_reader%bkspc(parser%getunit()) end if diff --git a/src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 b/src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 index 6e87153da4f..8d386cfb3ab 100644 --- a/src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 +++ b/src/Utilities/Idm/mf6blockfile/Mf6FileGridInput.f90 @@ -71,78 +71,58 @@ subroutine bndgrid_init(this, mf6_input, component_name, & contiguous :: tas_fnames character(len=LINELENGTH) :: fname integer(I4B) :: tas6_size, n - ! - ! -- initialize base type + + ! initialize base type call this%DynamicPkgLoadType%init(mf6_input, component_name, & component_input_name, & input_name, iperblock, iout) - ! -- initialize + ! initialize nullify (this%aux_tasnames) nullify (this%param_tasnames) this%tas_active = 0 this%iout = iout - ! - ! -- load static input + + ! load static input call loader%load(parser, mf6_input, this%nc_vars, this%input_name, iout) - ! - ! -- create tasmanager + + ! create tasmanager allocate (this%tasmanager) call tasmanager_cr(this%tasmanager, modelname=this%mf6_input%component_name, & iout=this%iout) - ! - ! -- determine if TAS6 files were provided in OPTIONS block + + ! determine if TAS6 files were provided in OPTIONS block call get_isize('TAS6_FILENAME', this%mf6_input%mempath, tas6_size) - ! if (tas6_size > 0) then - ! this%tas_active = 1 - ! call mem_setptr(tas_fnames, 'TAS6_FILENAME', this%mf6_input%mempath) - ! - ! -- add files to tasmanager + ! add files to tasmanager do n = 1, size(tas_fnames) fname = tas_fnames(n) call this%tasmanager%add_tasfile(fname) end do - ! end if - ! - ! -- initialize input context memory + + ! initialize input context memory call this%bound_context%create(mf6_input, this%readasarrays) - ! - ! -- allocate dfn params + + ! allocate dfn params call this%params_alloc() - ! - ! -- allocate memory for storing TAS strings + + ! allocate memory for storing TAS strings call this%tas_arrays_alloc() - ! - ! -- return - return end subroutine bndgrid_init subroutine bndgrid_df(this) - ! -- modules - ! -- dummy class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType - ! call this%tasmanager%tasmanager_df() - ! - ! -- return - return end subroutine bndgrid_df subroutine bndgrid_ad(this) - ! -- modules class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType - ! call this%tasmanager%ad() - ! - ! -- return - return end subroutine bndgrid_ad subroutine bndgrid_rp(this, parser) - ! -- modules use MemoryManagerModule, only: mem_setptr use BlockParserModule, only: BlockParserType use InputDefinitionModule, only: InputParamDefinitionType @@ -152,54 +132,47 @@ subroutine bndgrid_rp(this, parser) use IdmLoggerModule, only: idm_log_header, idm_log_close, idm_log_var class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType type(BlockParserType), pointer, intent(inout) :: parser - ! -- local logical(LGP) :: endOfBlock, netcdf character(len=LINELENGTH) :: keyword, param_tag type(InputParamDefinitionType), pointer :: idt integer(I4B) :: iaux, iparam character(len=LENTIMESERIESNAME) :: tas_name integer(I4B), dimension(:), pointer, contiguous :: int1d - ! - ! -- reset for this period + + ! reset for this period call this%reset() - ! - ! -- log lst file header + + ! log lst file header call idm_log_header(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) - ! - ! -- read array block + + ! read array block do - ! -- initialize + ! initialize iaux = 0 netcdf = .false. - ! - ! -- read next line + + ! read next line call parser%GetNextLine(endOfBlock) if (endOfBlock) exit - ! - ! -- read param_tag + ! read param_tag call parser%GetStringCaps(param_tag) - ! - ! -- is param tag an auxvar? + + ! is param tag an auxvar? iaux = ifind_charstr(this%bound_context%auxname_cst, param_tag) - ! - ! -- any auvxar corresponds to the definition tag 'AUX' + ! any auvxar corresponds to the definition tag 'AUX' if (iaux > 0) param_tag = 'AUX' - ! - ! -- set input definition + + ! set input definition idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & 'PERIOD', param_tag, this%input_name) - ! - ! -- look for TAS and NetCDF keywords + ! look for TAS and NetCDF keywords call parser%GetStringCaps(keyword) - ! if (keyword == 'TIMEARRAYSERIES') then if (this%tas_active /= 0) then - ! call parser%GetStringCaps(tas_name) - ! if (param_tag == 'AUX') then this%aux_tasnames(iaux) = tas_name else @@ -207,29 +180,25 @@ subroutine bndgrid_rp(this, parser) this%param_tasnames(iparam) = tas_name this%param_reads(iparam)%invar = 2 end if - ! - ! -- log variable + ! log variable call idm_log_var(param_tag, this%mf6_input%mempath, this%iout, .true.) - ! - ! -- cycle to next input param + ! cycle to next input param cycle else ! TODO: throw error end if - ! else if (keyword == 'NETCDF') then netcdf = .true. end if - ! - ! -- read and load the parameter + + ! read and load the parameter call this%param_load(parser, idt, this%mf6_input%mempath, netcdf, iaux) - ! end do - ! - ! -- check if layer index variable was read + + ! check if layer index variable was read ! TODO: assumes layer index variable is always in scope if (this%param_reads(1)%invar == 0) then - ! -- set to default of 1 without updating invar + ! set to default of 1 without updating invar idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & @@ -238,73 +207,54 @@ subroutine bndgrid_rp(this, parser) call mem_setptr(int1d, idt%mf6varname, this%mf6_input%mempath) int1d = 1 end if - ! - ! + if (this%tas_active /= 0) then call this%tas_links_create(parser%iuactive) end if - ! - ! -- log lst file header + + ! log lst file header call idm_log_close(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) - ! - ! -- return - return end subroutine bndgrid_rp subroutine bndgrid_destroy(this) - ! -- modules class(BoundGridInputType), intent(inout) :: this !< Mf6FileGridInputType - ! deallocate (this%tasmanager) - ! - ! -- return - return end subroutine bndgrid_destroy subroutine bndgrid_reset(this) - ! -- modules class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType integer(I4B) :: n, m - ! + if (this%tas_active /= 0) then - ! - ! -- reset tasmanager + ! reset tasmanager call this%tasmanager%reset(this%mf6_input%subcomponent_name) - ! - ! -- reinitialize tas name arrays + ! reinitialize tas name arrays call this%init_charstr1d('AUXTASNAME', this%input_name) call this%init_charstr1d('PARAMTASNAME', this%input_name) end if - ! + do n = 1, this%nparam - ! -- reset read state + ! reset read state this%param_reads(n)%invar = 0 end do - ! - ! -- explicitly reset auxvar array each period + + ! explicitly reset auxvar array each period do m = 1, this%bound_context%ncpl do n = 1, this%bound_context%naux this%bound_context%auxvar(n, m) = DZERO end do end do - ! - ! -- return - return end subroutine bndgrid_reset subroutine init_charstr1d(this, varname, input_name) - ! -- modules use MemoryManagerModule, only: mem_setptr - ! -- dummy class(BoundGridInputType) :: this character(len=*), intent(in) :: varname character(len=*), intent(in) :: input_name - ! -- local type(CharacterStringType), dimension(:), pointer, & contiguous :: charstr1d integer(I4B) :: n - ! call mem_setptr(charstr1d, varname, this%mf6_input%mempath) do n = 1, size(charstr1d) charstr1d(n) = '' @@ -312,37 +262,30 @@ subroutine init_charstr1d(this, varname, input_name) end subroutine init_charstr1d subroutine bndgrid_params_alloc(this) - ! -- modules - ! -- dummy class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType character(len=LENVARNAME) :: rs_varname integer(I4B), pointer :: intvar integer(I4B) :: iparam - ! - ! -- set in scope param names + + ! set in scope param names call this%bound_context%bound_params(this%param_names, this%nparam, & this%input_name) - ! call this%bound_context%allocate_arrays() - ! - ! -- allocate and set param_reads pointer array + + ! allocate and set param_reads pointer array allocate (this%param_reads(this%nparam)) - ! + ! store read state variable pointers do iparam = 1, this%nparam - ! -- allocate and store name of read state variable + ! allocate and store name of read state variable rs_varname = this%bound_context%rsv_alloc(this%param_names(iparam)) call mem_setptr(intvar, rs_varname, this%mf6_input%mempath) this%param_reads(iparam)%invar => intvar this%param_reads(iparam)%invar = 0 end do - ! - ! -- return - return end subroutine bndgrid_params_alloc subroutine bndgrid_param_load(this, parser, idt, mempath, netcdf, iaux) - ! -- modules use TdisModule, only: kper use MemoryManagerModule, only: mem_setptr use ArrayHandlersModule, only: ifind @@ -353,22 +296,19 @@ subroutine bndgrid_param_load(this, parser, idt, mempath, netcdf, iaux) use Integer1dReaderModule, only: read_int1d use LoadNCInputModule, only: netcdf_read_array use IdmLoggerModule, only: idm_log_var - ! -- dummy class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType type(BlockParserType), intent(in) :: parser type(InputParamDefinitionType), intent(in) :: idt character(len=*), intent(in) :: mempath logical(LGP), intent(in) :: netcdf integer(I4B), intent(in) :: iaux - ! -- local integer(I4B), dimension(:), pointer, contiguous :: int1d real(DP), dimension(:), pointer, contiguous :: dbl1d real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B) :: iparam, n - ! + select case (idt%datatype) case ('INTEGER1D') - ! call mem_setptr(int1d, idt%mf6varname, mempath) if (netcdf) then call netcdf_read_array(int1d, this%bound_context%mshape, idt, & @@ -378,9 +318,7 @@ subroutine bndgrid_param_load(this, parser, idt, mempath, netcdf, iaux) call read_int1d(parser, int1d, idt%mf6varname) end if call idm_log_var(int1d, idt%tagname, mempath, this%iout) - ! case ('DOUBLE1D') - ! call mem_setptr(dbl1d, idt%mf6varname, mempath) if (netcdf) then call netcdf_read_array(dbl1d, this%bound_context%mshape, idt, & @@ -390,9 +328,7 @@ subroutine bndgrid_param_load(this, parser, idt, mempath, netcdf, iaux) call read_dbl1d(parser, dbl1d, idt%mf6varname) end if call idm_log_var(dbl1d, idt%tagname, mempath, this%iout) - ! case ('DOUBLE2D') - ! call mem_setptr(dbl2d, idt%mf6varname, mempath) allocate (dbl1d(this%bound_context%ncpl)) if (netcdf) then @@ -407,67 +343,49 @@ subroutine bndgrid_param_load(this, parser, idt, mempath, netcdf, iaux) end do call idm_log_var(dbl1d, idt%tagname, mempath, this%iout) deallocate (dbl1d) - ! case default - ! errmsg = 'IDM unimplemented. Mf6FileGridInput::param_load & &datatype='//trim(idt%datatype) call store_error(errmsg) call store_error_filename(this%input_name) - ! end select - ! - ! -- if param is tracked set read state + + ! if param is tracked set read state iparam = ifind(this%param_names, idt%tagname) if (iparam > 0) then this%param_reads(iparam)%invar = 1 end if - ! - ! -- return - return end subroutine bndgrid_param_load subroutine bndgrid_tas_arrays_alloc(this) - ! -- modules use MemoryManagerModule, only: mem_allocate class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType - ! - ! -- count params other than AUX + + ! count params other than AUX if (this%tas_active /= 0) then - ! call mem_allocate(this%aux_tasnames, LENTIMESERIESNAME, & this%bound_context%naux, 'AUXTASNAME', & this%mf6_input%mempath) call mem_allocate(this%param_tasnames, LENTIMESERIESNAME, this%nparam, & 'PARAMTASNAME', this%mf6_input%mempath) - ! call this%init_charstr1d('AUXTASNAME', this%input_name) call this%init_charstr1d('PARAMTASNAME', this%input_name) - ! else - ! call mem_allocate(this%aux_tasnames, LENTIMESERIESNAME, 0, & 'AUXTASNAME', this%mf6_input%mempath) call mem_allocate(this%param_tasnames, LENTIMESERIESNAME, 0, & 'PARAMTASNAME', this%mf6_input%mempath) - ! end if - ! - ! -- return - return end subroutine bndgrid_tas_arrays_alloc ! FLUX and SFAC are handled in model context subroutine bndgrid_tas_links_create(this, inunit) - ! -- modules use InputDefinitionModule, only: InputParamDefinitionType use DefinitionSelectModule, only: get_param_definition_type - ! -- dummy class(BoundGridInputType), intent(inout) :: this !< BoundGridInputType integer(I4B), intent(in) :: inunit - ! -- local type(InputParamDefinitionType), pointer :: idt - ! -- non-contiguous because a slice of bound is passed + ! non-contiguous because a slice of bound is passed real(DP), dimension(:), pointer :: auxArrayPtr, bndArrayPtr real(DP), dimension(:), pointer, contiguous :: bound integer(I4B), dimension(:), pointer, contiguous :: nodelist @@ -475,19 +393,18 @@ subroutine bndgrid_tas_links_create(this, inunit) character(len=LENAUXNAME) :: aux_name logical :: convertFlux integer(I4B) :: n - ! - ! -- initialize + + ! initialize nullify (auxArrayPtr) nullify (bndArrayPtr) nullify (nodelist) convertflux = .false. - ! + ! Create AUX Time Array Series links do n = 1, this%bound_context%naux tas_name = this%aux_tasnames(n) - ! if (tas_name /= '') then - ! -- set auxvar pointer + ! set auxvar pointer auxArrayPtr => this%bound_context%auxvar(n, :) aux_name = this%bound_context%auxname_cst(n) call this%tasmanager%MakeTasLink(this%mf6_input%subcomponent_name, & @@ -496,21 +413,20 @@ subroutine bndgrid_tas_links_create(this, inunit) nodelist, inunit) end if end do - ! + ! Create BND Time Array Series links do n = 1, this%nparam - ! -- assign param definition pointer + ! assign param definition pointer idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & 'PERIOD', this%param_names(n), & this%input_name) - ! if (idt%timeseries) then if (this%param_reads(n)%invar == 2) then tas_name = this%param_tasnames(n) call mem_setptr(bound, idt%mf6varname, this%mf6_input%mempath) - ! -- set bound pointer + ! set bound pointer bndArrayPtr => bound(:) call this%tasmanager%MakeTasLink(this%mf6_input%subcomponent_name, & bndArrayPtr, & @@ -520,9 +436,6 @@ subroutine bndgrid_tas_links_create(this, inunit) end if end if end do - ! - ! -- return - return end subroutine bndgrid_tas_links_create end module Mf6FileGridInputModule diff --git a/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 b/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 index 62582d0fd6b..6a8666e6160 100644 --- a/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 +++ b/src/Utilities/Idm/mf6blockfile/Mf6FileListInput.f90 @@ -70,170 +70,137 @@ subroutine bndlist_init(this, mf6_input, component_name, component_input_name, & contiguous :: ts_fnames character(len=LINELENGTH) :: fname integer(I4B) :: ts6_size, n - ! - ! -- init loader + + ! init loader call this%DynamicPkgLoadType%init(mf6_input, component_name, & component_input_name, input_name, & iperblock, iout) - ! -- initialize scalars + ! initialize scalars this%iboundname = 0 this%ts_active = 0 - ! - ! -- load static input + + ! load static input call loader%load(parser, mf6_input, this%nc_vars, this%input_name, iout) - ! - ! -- create tsmanager + + ! create tsmanager allocate (this%tsmanager) call tsmanager_cr(this%tsmanager, iout) - ! - ! -- determine if TS6 files were provided in OPTIONS block + + ! determine if TS6 files were provided in OPTIONS block call get_isize('TS6_FILENAME', this%mf6_input%mempath, ts6_size) - ! if (ts6_size > 0) then - ! this%ts_active = 1 call mem_setptr(ts_fnames, 'TS6_FILENAME', this%mf6_input%mempath) - ! do n = 1, size(ts_fnames) fname = ts_fnames(n) call this%tsmanager%add_tsfile(fname, GetUnit()) end do - ! end if - ! - ! -- initialize package input context + + ! initialize package input context call this%bound_context%create(mf6_input, this%readasarrays) - ! - ! -- store in scope SA cols for list input + + ! store in scope SA cols for list input call this%bound_context%bound_params(this%param_names, this%nparam, & this%input_name, create=.false.) - ! - ! -- construct and set up the struct array object + ! construct and set up the struct array object call this%create_structarray() - ! - ! -- finalize input context setup + + ! finalize input context setup call this%bound_context%allocate_arrays() end subroutine bndlist_init subroutine bndlist_df(this) - ! -- modules - ! -- dummy class(BoundListInputType), intent(inout) :: this !< ListInputType - ! - ! -- define tsmanager + ! define tsmanager call this%tsmanager%tsmanager_df() end subroutine bndlist_df subroutine bndlist_ad(this) - ! -- modules class(BoundListInputType), intent(inout) :: this !< ListInputType - ! - ! -- advance timeseries + ! advance timeseries call this%tsmanager%ad() end subroutine bndlist_ad subroutine bndlist_reset(this) - ! -- modules class(BoundListInputType), intent(inout) :: this !< ListInputType - ! - ! -- reset tsmanager + ! reset tsmanager call this%tsmanager%reset(this%mf6_input%subcomponent_name) end subroutine bndlist_reset subroutine bndlist_rp(this, parser) - ! -- modules use BlockParserModule, only: BlockParserType use LoadMf6FileModule, only: read_control_record use StructVectorModule, only: StructVectorType use IdmLoggerModule, only: idm_log_header, idm_log_close - ! -- dummy class(BoundListInputType), intent(inout) :: this type(BlockParserType), pointer, intent(inout) :: parser - ! -- local integer(I4B) :: ibinary integer(I4B) :: oc_inunit logical(LGP) :: ts_active - ! + call this%reset() - ! ibinary = read_control_record(parser, oc_inunit, this%iout) - ! - ! -- log lst file header + + ! log lst file header call idm_log_header(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) - ! + if (ibinary == 1) then - ! this%bound_context%nbound = & this%structarray%read_from_binary(oc_inunit, this%iout) - ! call parser%terminateblock() - ! close (oc_inunit) - ! else - ! ts_active = (this%ts_active /= 0) - ! this%bound_context%nbound = & this%structarray%read_from_parser(parser, ts_active, this%iout) end if - ! + ! update ts links if (this%ts_active /= 0) then call this%ts_update(this%structarray) end if - ! - ! -- close logging statement + + ! close logging statement call idm_log_close(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) end subroutine bndlist_rp subroutine bndlist_destroy(this) - ! -- modules class(BoundListInputType), intent(inout) :: this !< BoundListInputType - ! deallocate (this%tsmanager) - ! - ! -- deallocate StructArray call destructStructArray(this%structarray) - ! call this%bound_context%destroy() end subroutine bndlist_destroy subroutine bndlist_ts_link_bnd(this, structvector, ts_strloc) - ! -- modules use TimeSeriesLinkModule, only: TimeSeriesLinkType use TimeSeriesManagerModule, only: read_value_or_time_series use StructVectorModule, only: StructVectorType, TSStringLocType - ! -- dummy class(BoundListInputType), intent(inout) :: this type(StructVectorType), pointer, intent(in) :: structvector type(TSStringLocType), pointer, intent(in) :: ts_strloc - ! -- local real(DP), pointer :: bndElem type(TimeSeriesLinkType), pointer :: tsLinkBnd type(StructVectorType), pointer :: sv_bound character(len=LENBOUNDNAME) :: boundname - ! + nullify (tsLinkBnd) - ! - ! -- set bound element + + ! set bound element bndElem => structvector%dbl1d(ts_strloc%row) - ! - ! -- set link + + ! set link call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & ts_strloc%structarray_col, bndElem, & this%mf6_input%subcomponent_name, & 'BND', this%tsmanager, & this%bound_context%iprpak, tsLinkBnd) - ! if (associated(tsLinkBnd)) then - ! - ! -- set variable name + ! set variable name tsLinkBnd%Text = structvector%idt%mf6varname - ! - ! -- set boundname if provided + ! set boundname if provided if (this%bound_context%inamedbound > 0) then sv_bound => this%structarray%get(this%iboundname) boundname = sv_bound%charstr1d(ts_strloc%row) @@ -243,134 +210,104 @@ subroutine bndlist_ts_link_bnd(this, structvector, ts_strloc) end subroutine bndlist_ts_link_bnd subroutine bndlist_ts_link_aux(this, structvector, ts_strloc) - ! -- modules use TimeSeriesLinkModule, only: TimeSeriesLinkType use TimeSeriesManagerModule, only: read_value_or_time_series use StructVectorModule, only: StructVectorType, TSStringLocType - ! -- dummy class(BoundListInputType), intent(inout) :: this type(StructVectorType), pointer, intent(in) :: structvector type(TSStringLocType), pointer, intent(in) :: ts_strloc - ! -- local real(DP), pointer :: bndElem type(TimeSeriesLinkType), pointer :: tsLinkAux type(StructVectorType), pointer :: sv_bound character(len=LENBOUNDNAME) :: boundname - ! + nullify (tsLinkAux) - ! - ! -- set bound element + + ! set bound element bndElem => structvector%dbl2d(ts_strloc%col, ts_strloc%row) - ! - ! -- set link + + ! set link call read_value_or_time_series(ts_strloc%token, ts_strloc%row, & ts_strloc%structarray_col, bndElem, & this%mf6_input%subcomponent_name, & 'AUX', this%tsmanager, & this%bound_context%iprpak, tsLinkAux) - if (associated(tsLinkAux)) then - ! - ! -- set variable name + ! set variable name tsLinkAux%Text = this%bound_context%auxname_cst(ts_strloc%col) - ! - ! -- set boundname if provided + ! set boundname if provided if (this%bound_context%inamedbound > 0) then sv_bound => this%structarray%get(this%iboundname) boundname = sv_bound%charstr1d(ts_strloc%row) tsLinkAux%BndName = boundname end if - ! end if end subroutine bndlist_ts_link_aux subroutine bndlist_ts_update(this, structarray) - ! -- modules use SimModule, only: count_errors, store_error_filename use StructVectorModule, only: TSStringLocType use StructVectorModule, only: StructVectorType - ! -- dummy class(BoundListInputType), intent(inout) :: this type(StructArrayType), pointer, intent(inout) :: structarray - ! -- local integer(I4B) :: n, m type(TSStringLocType), pointer :: ts_strloc type(StructVectorType), pointer :: sv - ! - do m = 1, structarray%count() + do m = 1, structarray%count() sv => structarray%get(m) - if (sv%idt%timeseries) then - ! do n = 1, sv%ts_strlocs%count() ts_strloc => sv%get_ts_strloc(n) call this%ts_link(sv, ts_strloc) end do - ! call sv%clear() end if end do - ! - ! -- terminate if errors were detected + + ! terminate if errors were detected if (count_errors() > 0) then call store_error_filename(this%input_name) end if end subroutine bndlist_ts_update subroutine bndlist_ts_link(this, structvector, ts_strloc) - ! -- modules use StructVectorModule, only: StructVectorType, TSStringLocType - ! -- dummy class(BoundListInputType), intent(inout) :: this type(StructVectorType), pointer, intent(in) :: structvector type(TSStringLocType), pointer, intent(in) :: ts_strloc - ! -- local - ! select case (structvector%memtype) - case (2) ! -- dbl1d - ! + case (2) ! dbl1d call this%ts_link_bnd(structvector, ts_strloc) - ! - case (6) ! -- dbl2d - ! + case (6) ! dbl2d call this%ts_link_aux(structvector, ts_strloc) - ! case default end select end subroutine bndlist_ts_link subroutine bndlist_create_structarray(this) - ! -- modules use InputDefinitionModule, only: InputParamDefinitionType use DefinitionSelectModule, only: get_param_definition_type - ! -- dummy class(BoundListInputType), intent(inout) :: this - ! -- local type(InputParamDefinitionType), pointer :: idt integer(I4B) :: icol - ! - ! -- construct and set up the struct array object + + ! construct and set up the struct array object this%structarray => constructStructArray(this%mf6_input, this%nparam, & this%bound_context%maxbound, 0, & this%mf6_input%mempath, & this%mf6_input%component_mempath) - ! - ! -- set up struct array + ! set up struct array do icol = 1, this%nparam - ! idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & 'PERIOD', & this%param_names(icol), this%input_name) - ! - ! -- allocate variable in memory manager + ! allocate variable in memory manager call this%structarray%mem_create_vector(icol, idt) - ! - ! -- store boundname index when found + ! store boundname index when found if (idt%mf6varname == 'BOUNDNAME') this%iboundname = icol - ! end do end subroutine bndlist_create_structarray diff --git a/src/Utilities/Idm/mf6blockfile/Mf6FileStoInput.f90 b/src/Utilities/Idm/mf6blockfile/Mf6FileStoInput.f90 index 4af091d48bb..2648724f108 100644 --- a/src/Utilities/Idm/mf6blockfile/Mf6FileStoInput.f90 +++ b/src/Utilities/Idm/mf6blockfile/Mf6FileStoInput.f90 @@ -43,62 +43,58 @@ subroutine sto_init(this, mf6_input, component_name, component_input_name, & type(BlockParserType), pointer, intent(inout) :: parser integer(I4B), intent(in) :: iout type(LoadMf6FileType) :: loader - ! - ! -- init loader + + ! init loader call this%DynamicPkgLoadType%init(mf6_input, component_name, & component_input_name, input_name, & iperblock, iout) - ! - ! -- initialize static loader + ! initialize static loader call loader%load(parser, mf6_input, this%nc_vars, this%input_name, iout) - ! - ! -- allocate storage string + + ! allocate storage string call mem_allocate(this%storage, LINELENGTH, 'STORAGE', this%mf6_input%mempath) - ! - ! -- initialize storage to TRANSIENT (model iss=0) + + ! initialize storage to TRANSIENT (model iss=0) this%storage = 'TRANSIENT' end subroutine sto_init subroutine sto_rp(this, parser) - ! -- modules use BlockParserModule, only: BlockParserType use DefinitionSelectModule, only: get_param_definition_type use IdmLoggerModule, only: idm_log_header, idm_log_close, idm_log_var - ! -- dummy class(StoInputType), intent(inout) :: this type(BlockParserType), pointer, intent(inout) :: parser - ! -- local character(len=LINELENGTH) :: tagname type(InputParamDefinitionType), pointer :: idt logical(LGP) :: endOfBlock - ! - ! -- read next line + + ! read next line call parser%GetNextLine(endOfBlock) - ! - ! -- return if no input + + ! return if no input if (endOfBlock) return - ! - ! -- read the tag + + ! read the tag call parser%GetStringCaps(tagname) - ! - ! -- verify tag is supported + + ! verify tag is supported idt => get_param_definition_type(this%mf6_input%param_dfns, & this%mf6_input%component_type, & this%mf6_input%subcomponent_type, & 'PERIOD', tagname, this%input_name) - ! -- set storage + ! set storage this%storage = idt%tagname - ! - ! -- only one input line is expected, terminate block + + ! only one input line is expected, terminate block call parser%terminateblock() - ! - ! -- log lst file header + + ! log lst file header call idm_log_header(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) - ! + call idm_log_var(this%storage, tagname, this%mf6_input%mempath, this%iout) - ! - ! -- close logging statement + + ! close logging statement call idm_log_close(this%mf6_input%component_name, & this%mf6_input%subcomponent_name, this%iout) end subroutine sto_rp diff --git a/src/Utilities/Idm/mf6blockfile/StructArray.f90 b/src/Utilities/Idm/mf6blockfile/StructArray.f90 index 44c3575ea03..c9c194d19a3 100644 --- a/src/Utilities/Idm/mf6blockfile/StructArray.f90 +++ b/src/Utilities/Idm/mf6blockfile/StructArray.f90 @@ -78,35 +78,35 @@ function constructStructArray(mf6_input, ncol, nrow, blocknum, mempath, & character(len=*), intent(in) :: mempath !< memory path for storing the vector character(len=*), intent(in) :: component_mempath type(StructArrayType), pointer :: struct_array !< new StructArrayType - ! - ! -- allocate StructArrayType + + ! allocate StructArrayType allocate (struct_array) - ! - ! -- set description of input + + ! set description of input struct_array%mf6_input = mf6_input - ! - ! -- set number of arrays + + ! set number of arrays struct_array%ncol = ncol - ! - ! -- set rows if known or set deferred + + ! set rows if known or set deferred struct_array%nrow = nrow if (struct_array%nrow == -1) then struct_array%nrow = 0 struct_array%deferred_shape = .true. end if - ! - ! -- set blocknum + + ! set blocknum if (blocknum > 0) then struct_array%blocknum = blocknum else struct_array%blocknum = 0 end if - ! - ! + + ! set mempath struct_array%mempath = mempath struct_array%component_mempath = component_mempath - ! - ! -- allocate StructVectorType objects + + ! allocate StructVectorType objects allocate (struct_array%struct_vectors(ncol)) allocate (struct_array%startidx(ncol)) allocate (struct_array%numcols(ncol)) @@ -116,7 +116,6 @@ end function constructStructArray !< subroutine destructStructArray(struct_array) type(StructArrayType), pointer, intent(inout) :: struct_array !< StructArrayType to destroy - deallocate (struct_array%struct_vectors) deallocate (struct_array%startidx) deallocate (struct_array%numcols) @@ -132,55 +131,43 @@ subroutine mem_create_vector(this, icol, idt) type(InputParamDefinitionType), pointer :: idt type(StructVectorType) :: sv integer(I4B) :: numcol - ! + + ! initialize numcol = 1 - ! sv%idt => idt sv%icol = icol - ! - ! -- set size + + ! set size if (this%deferred_shape) then sv%size = this%deferred_size_init else sv%size = this%nrow end if - ! - ! -- allocate array memory for StructVectorType + + ! allocate array memory for StructVectorType select case (idt%datatype) - ! case ('INTEGER') - ! call this%allocate_int_type(sv) - ! case ('DOUBLE') - ! call this%allocate_dbl_type(sv) - ! case ('STRING', 'KEYWORD') - ! call this%allocate_charstr_type(sv) - ! case ('INTEGER1D') - ! call this%allocate_int1d_type(sv) if (sv%memtype == 5) then numcol = sv%intshape end if - ! case ('DOUBLE1D') - ! call this%allocate_dbl1d_type(sv) numcol = sv%intshape - ! case default errmsg = 'IDM unimplemented. StructArray::mem_create_vector & &type='//trim(idt%datatype) call store_error(errmsg, .true.) end select - ! - ! -- set the object in the Struct Array + + ! set the object in the Struct Array this%struct_vectors(icol) = sv - ! this%numcols(icol) = numcol if (icol == 1) then this%startidx(icol) = 1 @@ -215,22 +202,22 @@ subroutine allocate_int_type(this, sv) type(StructVectorType), intent(inout) :: sv integer(I4B), dimension(:), pointer, contiguous :: int1d integer(I4B) :: j, nrow - ! + if (this%deferred_shape) then - ! -- shape not known, allocate locally + ! shape not known, allocate locally nrow = this%deferred_size_init allocate (int1d(this%deferred_size_init)) else - ! -- shape known, allocate in managed memory + ! shape known, allocate in managed memory nrow = this%nrow call mem_allocate(int1d, this%nrow, sv%idt%mf6varname, this%mempath) end if - ! - ! -- initialize vector values + + ! initialize vector values do j = 1, nrow int1d(j) = IZERO end do - ! + sv%memtype = 1 sv%int1d => int1d end subroutine allocate_int_type @@ -242,22 +229,22 @@ subroutine allocate_dbl_type(this, sv) type(StructVectorType), intent(inout) :: sv real(DP), dimension(:), pointer, contiguous :: dbl1d integer(I4B) :: j, nrow - ! + if (this%deferred_shape) then - ! -- shape not known, allocate locally + ! shape not known, allocate locally nrow = this%deferred_size_init allocate (dbl1d(this%deferred_size_init)) else - ! -- shape known, allocate in managed memory + ! shape known, allocate in managed memory nrow = this%nrow call mem_allocate(dbl1d, this%nrow, sv%idt%mf6varname, this%mempath) end if - ! - ! -- initialize + + ! initialize do j = 1, nrow dbl1d(j) = DZERO end do - ! + sv%memtype = 2 sv%dbl1d => dbl1d end subroutine allocate_dbl_type @@ -269,18 +256,18 @@ subroutine allocate_charstr_type(this, sv) type(StructVectorType), intent(inout) :: sv type(CharacterStringType), dimension(:), pointer, contiguous :: charstr1d integer(I4B) :: j - ! + if (this%deferred_shape) then allocate (charstr1d(this%deferred_size_init)) else call mem_allocate(charstr1d, LINELENGTH, this%nrow, & sv%idt%mf6varname, this%mempath) end if - ! + do j = 1, this%nrow charstr1d(j) = '' end do - ! + sv%memtype = 3 sv%charstr1d => charstr1d end subroutine allocate_charstr_type @@ -301,71 +288,60 @@ subroutine allocate_int1d_type(this, sv) type(CharacterStringType), dimension(:), contiguous, & pointer :: charstr1d integer(I4B) :: nrow, n, m - ! + if (sv%idt%shape == 'NCELLDIM') then - ! - ! -- if EXCHANGE set to NCELLDIM of appropriate model + ! if EXCHANGE set to NCELLDIM of appropriate model if (this%mf6_input%component_type == 'EXG') then - ! - ! -- set pointer to EXGID + ! set pointer to EXGID call mem_setptr(exgid, 'EXGID', this%mf6_input%mempath) - ! - ! -- set pointer to appropriate exchange model array + ! set pointer to appropriate exchange model array input_mempath = create_mem_path('SIM', 'NAM', idm_context) - ! if (sv%idt%tagname == 'CELLIDM1') then call mem_setptr(charstr1d, 'EXGMNAMEA', input_mempath) else if (sv%idt%tagname == 'CELLIDM2') then call mem_setptr(charstr1d, 'EXGMNAMEB', input_mempath) end if - ! - ! -- set the model name + + ! set the model name mname = charstr1d(exgid) - ! - ! -- set ncelldim pointer + + ! set ncelldim pointer input_mempath = create_mem_path(component=mname, context=idm_context) call mem_setptr(ncelldim, sv%idt%shape, input_mempath) else - ! call mem_setptr(ncelldim, sv%idt%shape, this%component_mempath) end if - ! + if (this%deferred_shape) then - ! -- shape not known, allocate locally + ! shape not known, allocate locally nrow = this%deferred_size_init allocate (int2d(ncelldim, this%deferred_size_init)) - ! else - ! -- shape known, allocate in managed memory + ! shape known, allocate in managed memory nrow = this%nrow call mem_allocate(int2d, ncelldim, this%nrow, & sv%idt%mf6varname, this%mempath) end if - ! - ! -- initialize + + ! initialize do m = 1, nrow do n = 1, ncelldim int2d(n, m) = IZERO end do end do - ! + sv%memtype = 5 sv%int2d => int2d sv%intshape => ncelldim - ! else - ! - ! -- allocate intvector object + ! allocate intvector object allocate (intvector) - ! - ! -- initialize STLVecInt + ! initialize STLVecInt call intvector%init() - ! sv%memtype = 4 sv%intvector => intvector sv%size = -1 - ! - ! -- set pointer to dynamic shape + ! set pointer to dynamic shape call mem_setptr(sv%intvector_shape, sv%idt%shape, this%mempath) end if end subroutine allocate_int1d_type @@ -379,48 +355,45 @@ subroutine allocate_dbl1d_type(this, sv) real(DP), dimension(:, :), pointer, contiguous :: dbl2d integer(I4B), pointer :: naux, nseg, nseg_1 integer(I4B) :: nseg1_isize, n, m - ! + if (sv%idt%shape == 'NAUX') then call mem_setptr(naux, sv%idt%shape, this%mempath) - ! call mem_allocate(dbl2d, naux, this%nrow, sv%idt%mf6varname, this%mempath) - ! - ! -- initialize + + ! initialize do m = 1, this%nrow do n = 1, naux dbl2d(n, m) = DZERO end do end do - ! + sv%memtype = 6 sv%dbl2d => dbl2d sv%intshape => naux - ! else if (sv%idt%shape == 'NSEG-1') then call mem_setptr(nseg, 'NSEG', this%mempath) - ! call get_isize('NSEG_1', this%mempath, nseg1_isize) - ! + if (nseg1_isize < 0) then call mem_allocate(nseg_1, 'NSEG_1', this%mempath) nseg_1 = nseg - 1 else call mem_setptr(nseg_1, 'NSEG_1', this%mempath) end if - ! + + ! allocate call mem_allocate(dbl2d, nseg_1, this%nrow, sv%idt%mf6varname, this%mempath) - ! - ! -- initialize + + ! initialize do m = 1, this%nrow do n = 1, nseg_1 dbl2d(n, m) = DZERO end do end do - ! + sv%memtype = 6 sv%dbl2d => dbl2d sv%intshape => nseg_1 - ! else errmsg = 'IDM unimplemented. StructArray::allocate_dbl1d_type & & unsupported shape "'//trim(sv%idt%shape)//'".' @@ -438,96 +411,84 @@ subroutine load_deferred_vector(this, icol) real(DP), dimension(:), pointer, contiguous :: p_dbl1d type(CharacterStringType), dimension(:), pointer, contiguous :: p_charstr1d character(len=LENVARNAME) :: varname - ! - ! -- set varname + + ! set varname varname = this%struct_vectors(icol)%idt%mf6varname - ! - ! -- check if already mem managed variable + ! check if already mem managed variable call get_isize(varname, this%mempath, isize) - ! - ! -- allocate and load based on memtype + + ! allocate and load based on memtype select case (this%struct_vectors(icol)%memtype) - ! - case (1) ! -- memtype integer - ! + case (1) ! memtype integer if (isize > -1) then - ! -- variable exists, reallocate and append + ! variable exists, reallocate and append call mem_setptr(p_int1d, varname, this%mempath) - ! -- Currently deferred vectors are appended to managed - ! memory vectors when they are already allocated - ! (e.g. SIMNAM SolutionGroup) + ! Currently deferred vectors are appended to managed + ! memory vectors when they are already allocated + ! (e.g. SIMNAM SolutionGroup) call mem_reallocate(p_int1d, this%nrow + isize, varname, this%mempath) do i = 1, this%nrow p_int1d(isize + i) = this%struct_vectors(icol)%int1d(i) end do else - ! - ! -- allocate memory manager vector + ! allocate memory manager vector call mem_allocate(p_int1d, this%nrow, varname, this%mempath) - ! - ! -- load local vector to managed memory + + ! load local vector to managed memory do i = 1, this%nrow p_int1d(i) = this%struct_vectors(icol)%int1d(i) end do end if - ! - ! -- deallocate local memory + + ! deallocate local memory deallocate (this%struct_vectors(icol)%int1d) - ! - ! -- update structvector + + ! update structvector this%struct_vectors(icol)%int1d => p_int1d this%struct_vectors(icol)%size = this%nrow - ! - case (2) ! -- memtype real - ! + case (2) ! memtype real if (isize > -1) then call mem_setptr(p_dbl1d, varname, this%mempath) call mem_reallocate(p_dbl1d, this%nrow + isize, varname, & this%mempath) - ! do i = 1, this%nrow p_dbl1d(isize + i) = this%struct_vectors(icol)%dbl1d(i) end do else call mem_allocate(p_dbl1d, this%nrow, varname, this%mempath) - ! + do i = 1, this%nrow p_dbl1d(i) = this%struct_vectors(icol)%dbl1d(i) end do end if - ! + deallocate (this%struct_vectors(icol)%dbl1d) - ! + this%struct_vectors(icol)%dbl1d => p_dbl1d this%struct_vectors(icol)%size = this%nrow ! - case (3) ! -- memtype charstring - ! + case (3) ! memtype charstring if (isize > -1) then call mem_setptr(p_charstr1d, varname, this%mempath) call mem_reallocate(p_charstr1d, LINELENGTH, this%nrow + isize, varname, & this%mempath) - do i = 1, this%nrow p_charstr1d(isize + i) = this%struct_vectors(icol)%charstr1d(i) end do else - ! call mem_allocate(p_charstr1d, LINELENGTH, this%nrow, varname, & this%mempath) - ! do i = 1, this%nrow p_charstr1d(i) = this%struct_vectors(icol)%charstr1d(i) end do end if - ! + deallocate (this%struct_vectors(icol)%charstr1d) - ! + this%struct_vectors(icol)%charstr1d => p_charstr1d this%struct_vectors(icol)%size = this%nrow - ! - case (4) ! -- memtype intvector + case (4) ! memtype intvector ! no-op case (5) if (isize > -1) then @@ -543,19 +504,18 @@ subroutine load_deferred_vector(this, icol) else call mem_allocate(p_int2d, this%struct_vectors(icol)%intshape, & this%nrow, varname, this%mempath) - ! do i = 1, this%nrow do j = 1, this%struct_vectors(icol)%intshape p_int2d(j, i) = this%struct_vectors(icol)%int2d(j, i) end do end do end if - ! + deallocate (this%struct_vectors(icol)%int2d) - ! + this%struct_vectors(icol)%int2d => p_int2d this%struct_vectors(icol)%size = this%nrow - ! + ! TODO: case (6) case default errmsg = 'IDM unimplemented. StructArray::load_deferred_vector & @@ -571,36 +531,32 @@ subroutine memload_vectors(this) integer(I4B) :: icol, j integer(I4B), dimension(:), pointer, contiguous :: p_intvector character(len=LENVARNAME) :: varname - ! + do icol = 1, this%ncol - ! - ! -- set varname + ! set varname varname = this%struct_vectors(icol)%idt%mf6varname - ! + if (this%struct_vectors(icol)%memtype == 4) then - ! -- intvectors always need to be loaded - ! - ! -- size intvector to number of values read + ! intvectors always need to be loaded + ! size intvector to number of values read call this%struct_vectors(icol)%intvector%shrink_to_fit() - ! - ! -- allocate memory manager vector + + ! allocate memory manager vector call mem_allocate(p_intvector, & this%struct_vectors(icol)%intvector%size, & varname, this%mempath) - ! - ! -- load local vector to managed memory + + ! load local vector to managed memory do j = 1, this%struct_vectors(icol)%intvector%size p_intvector(j) = this%struct_vectors(icol)%intvector%at(j) end do - ! - ! -- cleanup local memory + + ! cleanup local memory call this%struct_vectors(icol)%intvector%destroy() deallocate (this%struct_vectors(icol)%intvector) nullify (this%struct_vectors(icol)%intvector_shape) - ! else if (this%deferred_shape) then - ! - ! -- load as shape wasn't known + ! load as shape wasn't known call this%load_deferred_vector(icol) end if end do @@ -613,21 +569,16 @@ subroutine log_structarray_vars(this, iout) integer(I4B), intent(in) :: iout !< unit number for output integer(I4B) :: j integer(I4B), dimension(:), pointer, contiguous :: int1d - ! - ! -- idm variable logging + + ! idm variable logging do j = 1, this%ncol - ! - ! -- log based on memtype + ! log based on memtype select case (this%struct_vectors(j)%memtype) - ! - case (1) ! -- memtype integer - ! + case (1) ! memtype integer call idm_log_var(this%struct_vectors(j)%int1d, & this%struct_vectors(j)%idt%tagname, & this%mempath, iout) - ! - case (2) ! -- memtype real - ! + case (2) ! memtype real if (this%struct_vectors(j)%ts_strlocs%count() > 0) then call idm_log_var(this%struct_vectors(j)%idt%tagname, & this%mempath, iout, .false.) @@ -636,23 +587,16 @@ subroutine log_structarray_vars(this, iout) this%struct_vectors(j)%idt%tagname, & this%mempath, iout) end if - ! - case (4) ! -- memtype intvector - ! + case (4) ! memtype intvector call mem_setptr(int1d, this%struct_vectors(j)%idt%mf6varname, & this%mempath) - ! call idm_log_var(int1d, this%struct_vectors(j)%idt%tagname, & this%mempath, iout) - ! - case (5) ! -- memtype int2d - ! + case (5) ! memtype int2d call idm_log_var(this%struct_vectors(j)%int2d, & this%struct_vectors(j)%idt%tagname, & this%mempath, iout) - ! - case (6) ! -- memtype dbl2d - ! + case (6) ! memtype dbl2d if (this%struct_vectors(j)%ts_strlocs%count() > 0) then call idm_log_var(this%struct_vectors(j)%idt%tagname, & this%mempath, iout, .false.) @@ -661,9 +605,7 @@ subroutine log_structarray_vars(this, iout) this%struct_vectors(j)%idt%tagname, & this%mempath, iout) end if - ! end select - ! end do end subroutine log_structarray_vars @@ -677,87 +619,75 @@ subroutine check_reallocate(this) real(DP), dimension(:), pointer, contiguous :: p_dbl1d type(CharacterStringType), dimension(:), pointer, contiguous :: p_charstr1d integer(I4B) :: reallocate_mult - ! - ! -- set growth rate + + ! set growth rate reallocate_mult = 2 - ! + do j = 1, this%ncol - ! - ! -- reallocate based on memtype + ! reallocate based on memtype select case (this%struct_vectors(j)%memtype) - ! - case (1) ! -- memtype integer - ! - ! -- check if more space needed + case (1) ! memtype integer + ! check if more space needed if (this%nrow > this%struct_vectors(j)%size) then - ! - ! -- calculate new size + ! calculate new size newsize = this%struct_vectors(j)%size * reallocate_mult - ! - ! -- allocate new vector + ! allocate new vector allocate (p_int1d(newsize)) - ! - ! -- copy from old to new + + ! copy from old to new do i = 1, this%struct_vectors(j)%size p_int1d(i) = this%struct_vectors(j)%int1d(i) end do - ! - ! -- deallocate old vector + + ! deallocate old vector deallocate (this%struct_vectors(j)%int1d) - ! - ! -- update struct array object + + ! update struct array object this%struct_vectors(j)%int1d => p_int1d this%struct_vectors(j)%size = newsize end if - ! - case (2) ! -- memtype real + case (2) ! memtype real if (this%nrow > this%struct_vectors(j)%size) then - ! newsize = this%struct_vectors(j)%size * reallocate_mult - ! allocate (p_dbl1d(newsize)) - ! + do i = 1, this%struct_vectors(j)%size p_dbl1d(i) = this%struct_vectors(j)%dbl1d(i) end do - ! + deallocate (this%struct_vectors(j)%dbl1d) - ! + this%struct_vectors(j)%dbl1d => p_dbl1d this%struct_vectors(j)%size = newsize end if ! - case (3) ! -- memtype charstring + case (3) ! memtype charstring if (this%nrow > this%struct_vectors(j)%size) then - ! newsize = this%struct_vectors(j)%size * reallocate_mult - ! allocate (p_charstr1d(newsize)) - ! + do i = 1, this%struct_vectors(j)%size p_charstr1d(i) = this%struct_vectors(j)%charstr1d(i) end do - ! + deallocate (this%struct_vectors(j)%charstr1d) - ! + this%struct_vectors(j)%charstr1d => p_charstr1d this%struct_vectors(j)%size = newsize end if case (5) if (this%nrow > this%struct_vectors(j)%size) then - ! newsize = this%struct_vectors(j)%size * reallocate_mult - ! allocate (p_int2d(this%struct_vectors(j)%intshape, newsize)) - ! + do i = 1, this%struct_vectors(j)%size do k = 1, this%struct_vectors(j)%intshape p_int2d(k, i) = this%struct_vectors(j)%int2d(k, i) end do end do - ! + deallocate (this%struct_vectors(j)%int2d) - ! + this%struct_vectors(j)%int2d => p_int2d this%struct_vectors(j)%size = newsize end if @@ -783,22 +713,18 @@ subroutine write_struct_vector(this, parser, sv_col, irow, timeseries, & character(len=LINELENGTH) :: str character(len=:), allocatable :: line logical(LGP) :: preserve_case - ! + select case (this%struct_vectors(sv_col)%memtype) - ! - case (1) ! -- memtype integer - ! - ! -- if reloadable block and first col, store blocknum + case (1) ! memtype integer + ! if reloadable block and first col, store blocknum if (sv_col == 1 .and. this%blocknum > 0) then - ! -- store blocknum + ! store blocknum this%struct_vectors(sv_col)%int1d(irow) = this%blocknum else - ! -- read and store int + ! read and store int this%struct_vectors(sv_col)%int1d(irow) = parser%GetInteger() end if - ! - case (2) ! -- memtype real - ! + case (2) ! memtype real if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries) then call parser%GetString(str) if (present(auxcol)) then @@ -812,45 +738,35 @@ subroutine write_struct_vector(this, parser, sv_col, irow, timeseries, & else this%struct_vectors(sv_col)%dbl1d(irow) = parser%GetDouble() end if - ! - case (3) ! -- memtype charstring - ! + case (3) ! memtype charstring if (this%struct_vectors(sv_col)%idt%shape /= '') then - ! -- if last column with any shape, store rest of line + ! if last column with any shape, store rest of line if (sv_col == this%ncol) then call parser%GetRemainingLine(line) this%struct_vectors(sv_col)%charstr1d(irow) = line deallocate (line) end if else - ! - ! -- read string token + ! read string token preserve_case = (.not. this%struct_vectors(sv_col)%idt%preserve_case) call parser%GetString(str, preserve_case) this%struct_vectors(sv_col)%charstr1d(irow) = str end if - ! - case (4) ! -- memtype intvector - ! - ! -- get shape for this row + case (4) ! memtype intvector + ! get shape for this row numval = this%struct_vectors(sv_col)%intvector_shape(irow) - ! - ! -- read and store row values + ! read and store row values do n = 1, numval intval = parser%GetInteger() call this%struct_vectors(sv_col)%intvector%push_back(intval) end do - ! - case (5) ! -- memtype int2d - ! - ! -- read and store row values + case (5) ! memtype int2d + ! read and store row values do n = 1, this%struct_vectors(sv_col)%intshape this%struct_vectors(sv_col)%int2d(n, irow) = parser%GetInteger() end do - ! - case (6) ! -- memtype dbl2d - ! - ! -- read and store row values + case (6) ! memtype dbl2d + ! read and store row values do n = 1, this%struct_vectors(sv_col)%intshape if (this%struct_vectors(sv_col)%idt%timeseries .and. timeseries) then call parser%GetString(str) @@ -861,7 +777,6 @@ subroutine write_struct_vector(this, parser, sv_col, irow, timeseries, & this%struct_vectors(sv_col)%dbl2d(n, irow) = parser%GetDouble() end if end do - ! end select end subroutine write_struct_vector @@ -874,44 +789,33 @@ function read_from_parser(this, parser, timeseries, iout) result(irow) integer(I4B), intent(in) :: iout !< unit number for output integer(I4B) :: irow, j logical(LGP) :: endOfBlock - ! - ! -- initialize index irow + + ! initialize index irow irow = 0 - ! - ! -- read entire block + + ! read entire block do - ! - ! -- read next line + ! read next line call parser%GetNextLine(endOfBlock) - ! if (endOfBlock) then - ! -- no more lines + ! no more lines exit - ! else if (this%deferred_shape) then - ! - ! -- shape unknown, track lines read + ! shape unknown, track lines read this%nrow = this%nrow + 1 - ! - ! -- check and update memory allocation + ! check and update memory allocation call this%check_reallocate() end if - ! - ! -- update irow index + ! update irow index irow = irow + 1 - ! - ! -- handle line reads by column memtype + ! handle line reads by column memtype do j = 1, this%ncol - ! call this%write_struct_vector(parser, j, irow, timeseries, iout) - ! end do end do - ! - ! -- if deferred shape vectors were read, load to input path + ! if deferred shape vectors were read, load to input path call this%memload_vectors() - ! - ! -- log loaded variables + ! log loaded variables if (iout > 0) then call this%log_structarray_vars(iout) end if @@ -930,106 +834,84 @@ function read_from_binary(this, inunit, iout) result(irow) character(len=*), parameter :: fmtlsterronly = & "('Error reading LIST from file: ',& &1x,a,1x,' on UNIT: ',I0)" - ! - ! -- set error and exit if deferred shape + + ! set error and exit if deferred shape if (this%deferred_shape) then - ! errmsg = 'IDM unimplemented. StructArray::read_from_binary deferred shape & ¬ supported for binary inputs.' call store_error(errmsg, terminate=.TRUE.) - ! end if - ! - ! -- initialize + ! initialize irow = 0 ierr = 0 - ! readloop: do - ! - ! -- update irow index + ! update irow index irow = irow + 1 - ! - ! -- handle line reads by column memtype + ! handle line reads by column memtype do j = 1, this%ncol - ! select case (this%struct_vectors(j)%memtype) - ! - case (1) ! -- memtype integer + case (1) ! memtype integer read (inunit, iostat=ierr) this%struct_vectors(j)%int1d(irow) - case (2) ! -- memtype real + case (2) ! memtype real read (inunit, iostat=ierr) this%struct_vectors(j)%dbl1d(irow) - case (3) ! -- memtype charstring - ! + case (3) ! memtype charstring errmsg = 'List style binary inputs not supported & &for text columns, tag='// & trim(this%struct_vectors(j)%idt%tagname)//'.' call store_error(errmsg, terminate=.TRUE.) - ! - case (4) ! -- memtype intvector - ! - ! -- get shape for this row + case (4) ! memtype intvector + ! get shape for this row numval = this%struct_vectors(j)%intvector_shape(irow) - ! - ! -- read and store row values + ! read and store row values do k = 1, numval if (ierr == 0) then read (inunit, iostat=ierr) intval call this%struct_vectors(j)%intvector%push_back(intval) end if end do - ! - case (5) ! -- memtype int2d - ! - ! -- read and store row values + case (5) ! memtype int2d + ! read and store row values do k = 1, this%struct_vectors(j)%intshape if (ierr == 0) then read (inunit, iostat=ierr) this%struct_vectors(j)%int2d(k, irow) end if end do - ! - case (6) ! -- memtype dbl2d + case (6) ! memtype dbl2d do k = 1, this%struct_vectors(j)%intshape if (ierr == 0) then read (inunit, iostat=ierr) this%struct_vectors(j)%dbl2d(k, irow) end if end do end select - ! - ! -- handle error cases + + ! handle error cases select case (ierr) case (0) ! no error case (:-1) - ! - ! -- End of block was encountered + ! End of block was encountered irow = irow - 1 exit readloop - ! case (1:) - ! - ! -- Error + ! Error inquire (unit=inunit, name=fname) write (errmsg, fmtlsterronly) trim(adjustl(fname)), inunit call store_error(errmsg, terminate=.TRUE.) - ! case default end select - ! end do - ! if (irow == this%nrow) exit readloop - ! end do readloop - ! - ! -- Stop if errors were detected + + ! Stop if errors were detected !if (count_errors() > 0) then ! call store_error_unit(inunit) !end if - ! - ! -- if deferred shape vectors were read, load to input path + + ! if deferred shape vectors were read, load to input path call this%memload_vectors() - ! - ! -- log loaded variables + + ! log loaded variables if (iout > 0) then call this%log_structarray_vars(iout) end if diff --git a/src/Utilities/Idm/mf6blockfile/StructVector.f90 b/src/Utilities/Idm/mf6blockfile/StructVector.f90 index 05ef8cb16d0..c42a17268aa 100644 --- a/src/Utilities/Idm/mf6blockfile/StructVector.f90 +++ b/src/Utilities/Idm/mf6blockfile/StructVector.f90 @@ -64,21 +64,16 @@ module StructVectorModule contains function sv_read_token(this, token, structarray_col, col, row) result(val) - ! -- modules - ! -- dummy class(StructVectorType) :: this character(len=*), intent(in) :: token integer(I4B), intent(in) :: structarray_col integer(I4B), intent(in) :: col integer(I4B), intent(in) :: row real(DP) :: val - ! -- local integer(I4B) :: istat real(DP) :: r - ! - ! -- initialize + ! initialize val = DNODATA - ! read (token, *, iostat=istat) r if (istat == 0) then val = r @@ -88,39 +83,30 @@ function sv_read_token(this, token, structarray_col, col, row) result(val) end function sv_read_token subroutine sv_add_ts_strloc(this, token, structarray_col, col, row) - ! -- dummy variables class(StructVectorType) :: this character(len=*), intent(in) :: token integer(I4B), intent(in) :: structarray_col integer(I4B), intent(in) :: col integer(I4B), intent(in) :: row class(TSStringLocType), pointer :: str_field - ! -- local variables class(*), pointer :: obj - ! - ! -- allocate (str_field) str_field%structarray_col = structarray_col str_field%col = col str_field%row = row str_field%token = token - ! obj => str_field call this%ts_strlocs%Add(obj) end subroutine sv_add_ts_strloc function sv_get_ts_strloc(this, idx) result(res) - ! -- dummy variables class(StructVectorType) :: this integer(I4B), intent(in) :: idx !< package number class(TSStringLocType), pointer :: res - ! -- local variables class(*), pointer :: obj - ! - ! -- initialize res + ! initialize res res => null() - ! - ! -- get the package from the list + ! get the package from the list obj => this%ts_strlocs%GetItem(idx) if (associated(obj)) then select type (obj) @@ -133,21 +119,15 @@ end function sv_get_ts_strloc !> @brief !< subroutine sv_clear(this) - ! -- modules - ! -- dummy class(StructVectorType) :: this class(TSStringLocType), pointer :: ts_strloc integer(I4B) :: n - ! do n = 1, this%ts_strlocs%Count() ts_strloc => this%get_ts_strloc(n) deallocate (ts_strloc) nullify (ts_strloc) end do - ! call this%ts_strlocs%Clear() - ! - return end subroutine sv_clear end module StructVectorModule diff --git a/src/Utilities/Idm/netcdf/NCArrayReader.f90 b/src/Utilities/Idm/netcdf/NCArrayReader.f90 index f728e479a5e..11119dc32fc 100644 --- a/src/Utilities/Idm/netcdf/NCArrayReader.f90 +++ b/src/Utilities/Idm/netcdf/NCArrayReader.f90 @@ -35,7 +35,6 @@ module NCArrayReaderModule function is_layered(grid) result(layered) character(len=*), intent(in) :: grid logical(LGP) :: layered - ! select case (grid) case ('LAYERED MESH') layered = .true. @@ -44,9 +43,6 @@ function is_layered(grid) result(layered) case default layered = .false. end select - ! - ! -- return - return end function is_layered !> @brief Load NetCDF integer 1D array @@ -61,12 +57,11 @@ subroutine nc_array_load_int1d(int1d, mshape, idt, mf6_input, nc_vars, & character(len=*), intent(in) :: input_fname integer(I4B), intent(in) :: iout integer(I4B), optional, intent(in) :: kper - ! -- local integer(I4B) :: varid logical(LGP) :: layered - ! + layered = (idt%layered .and. is_layered(nc_vars%grid)) - ! + if (layered) then call load_integer1d_layered(int1d, mf6_input, mshape, idt, nc_vars, & input_fname) @@ -79,9 +74,6 @@ subroutine nc_array_load_int1d(int1d, mshape, idt, mf6_input, nc_vars, & call load_integer1d_type(int1d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) end if - ! - ! -- return - return end subroutine nc_array_load_int1d !> @brief Load NetCDF integer 2D array @@ -95,12 +87,11 @@ subroutine nc_array_load_int2d(int2d, mshape, idt, mf6_input, nc_vars, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname integer(I4B), intent(in) :: iout - ! -- local integer(I4B) :: varid logical(LGP) :: layered - ! + layered = (idt%layered .and. is_layered(nc_vars%grid)) - ! + if (layered) then call load_integer2d_layered(int2d, mf6_input, mshape, idt, nc_vars, & input_fname) @@ -109,9 +100,6 @@ subroutine nc_array_load_int2d(int2d, mshape, idt, mf6_input, nc_vars, & call load_integer2d_type(int2d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) end if - ! - ! -- return - return end subroutine nc_array_load_int2d !> @brief Load NetCDF integer 3D array @@ -125,12 +113,11 @@ subroutine nc_array_load_int3d(int3d, mshape, idt, mf6_input, nc_vars, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname integer(I4B), intent(in) :: iout - ! -- local integer(I4B) :: varid logical(LGP) :: layered - ! + layered = (idt%layered .and. is_layered(nc_vars%grid)) - ! + if (layered) then call load_integer3d_layered(int3d, mf6_input, mshape, idt, nc_vars, & input_fname) @@ -139,9 +126,6 @@ subroutine nc_array_load_int3d(int3d, mshape, idt, mf6_input, nc_vars, & call load_integer3d_type(int3d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) end if - ! - ! -- return - return end subroutine nc_array_load_int3d !> @brief Load NetCDF double 1D array @@ -157,16 +141,15 @@ subroutine nc_array_load_dbl1d(dbl1d, mshape, idt, mf6_input, nc_vars, & integer(I4B), intent(in) :: iout integer(I4B), optional, intent(in) :: kper integer(I4B), optional, intent(in) :: iaux - ! -- local integer(I4B) :: varid logical(LGP) :: layered - ! + if (present(kper)) then layered = (kper > 0 .and. is_layered(nc_vars%grid)) else layered = (idt%layered .and. is_layered(nc_vars%grid)) end if - ! + if (layered) then if (present(kper)) then call load_double1d_layered_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & @@ -185,9 +168,6 @@ subroutine nc_array_load_dbl1d(dbl1d, mshape, idt, mf6_input, nc_vars, & varid, input_fname) end if end if - ! - ! -- return - return end subroutine nc_array_load_dbl1d !> @brief Load NetCDF double 2D array @@ -201,12 +181,11 @@ subroutine nc_array_load_dbl2d(dbl2d, mshape, idt, mf6_input, nc_vars, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname integer(I4B), intent(in) :: iout - ! -- local integer(I4B) :: varid logical(LGP) :: layered - ! + layered = (idt%layered .and. is_layered(nc_vars%grid)) - ! + if (layered) then call load_double2d_layered(dbl2d, mf6_input, mshape, idt, nc_vars, & input_fname) @@ -215,9 +194,6 @@ subroutine nc_array_load_dbl2d(dbl2d, mshape, idt, mf6_input, nc_vars, & call load_double2d_type(dbl2d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) end if - ! - ! -- return - return end subroutine nc_array_load_dbl2d !> @brief Load NetCDF double 3D array @@ -231,12 +207,11 @@ subroutine nc_array_load_dbl3d(dbl3d, mshape, idt, mf6_input, nc_vars, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname integer(I4B), intent(in) :: iout - ! -- local integer(I4B) :: varid logical(LGP) :: layered - ! + layered = (idt%layered .and. is_layered(nc_vars%grid)) - ! + if (layered) then call load_double3d_layered(dbl3d, mf6_input, mshape, idt, nc_vars, & input_fname) @@ -245,16 +220,12 @@ subroutine nc_array_load_dbl3d(dbl3d, mshape, idt, mf6_input, nc_vars, & call load_double3d_type(dbl3d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) end if - ! - ! -- return - return end subroutine nc_array_load_dbl3d !> @brief load type 1d integer !< subroutine load_integer1d_type(int1d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) - ! -- dummy integer(I4B), dimension(:), contiguous, pointer, intent(in) :: int1d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -262,19 +233,17 @@ subroutine load_integer1d_type(int1d, mf6_input, mshape, idt, nc_vars, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars integer(I4B), intent(in) :: varid character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: array_shape integer(I4B), dimension(:, :, :), contiguous, pointer :: int3d_ptr integer(I4B), dimension(:, :), contiguous, pointer :: int2d_ptr integer(I4B) :: nvals - ! - ! -- initialize + + ! initialize nvals = 0 - ! + if (idt%shape == 'NODES') then - ! -- set number of values + ! set number of values nvals = product(mshape) - ! if (size(mshape) == 3) then int3d_ptr(1:mshape(3), 1:mshape(2), 1:mshape(1)) => int1d(1:nvals) call nf_verify(nf90_get_var(nc_vars%ncid, varid, int3d_ptr), & @@ -287,38 +256,31 @@ subroutine load_integer1d_type(int1d, mf6_input, mshape, idt, nc_vars, & call nf_verify(nf90_get_var(nc_vars%ncid, varid, int1d), nc_vars%nc_fname) end if else - ! -- interpret shape + ! interpret shape call get_shape_from_string(idt%shape, array_shape, mf6_input%mempath) - ! - ! -- set nvals + ! set nvals nvals = array_shape(1) - ! - ! -- read and set data + ! read and set data call nf_verify(nf90_get_var(nc_vars%ncid, varid, int1d), nc_vars%nc_fname) end if - ! - ! -- return - return end subroutine load_integer1d_type !> @brief load type 1d integer layered !< subroutine load_integer1d_layered(int1d, mf6_input, mshape, idt, nc_vars, & input_fname) - ! -- dummy integer(I4B), dimension(:), contiguous, pointer, intent(in) :: int1d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape type(InputParamDefinitionType), intent(in) :: idt type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: nlay, varid integer(I4B) :: k, ncpl integer(I4B) :: index_start, index_stop integer(I4B), dimension(:), contiguous, pointer :: int1d_ptr - ! + nullify (int1d_ptr) call get_layered_shape(mshape, nlay, layer_shape) @@ -333,16 +295,12 @@ subroutine load_integer1d_layered(int1d, mf6_input, mshape, idt, nc_vars, & nc_vars%nc_fname) index_start = index_stop + 1 end do - ! - ! -- return - return end subroutine load_integer1d_layered !> @brief load type 2d integer !< subroutine load_integer2d_type(int2d, mf6_input, mshape, idt, nc_vars, varid, & input_fname) - ! -- dummy integer(I4B), dimension(:, :), contiguous, pointer, intent(in) :: int2d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -350,13 +308,12 @@ subroutine load_integer2d_type(int2d, mf6_input, mshape, idt, nc_vars, varid, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars integer(I4B), intent(in) :: varid character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), contiguous, pointer :: int1d_ptr integer(I4B), dimension(:), allocatable :: array_shape integer(I4B) :: ncpl, nlay - ! + nullify (int1d_ptr) - ! + if (nc_vars%grid == 'STRUCTURED') then call nf_verify(nf90_get_var(nc_vars%ncid, varid, int2d), nc_vars%nc_fname) else if (nc_vars%grid == 'LAYERED MESH') then @@ -366,28 +323,23 @@ subroutine load_integer2d_type(int2d, mf6_input, mshape, idt, nc_vars, varid, & call nf_verify(nf90_get_var(nc_vars%ncid, varid, int1d_ptr), & nc_vars%nc_fname) end if - ! - ! -- return - return end subroutine load_integer2d_type !> @brief load type 2d integer layered !< subroutine load_integer2d_layered(int2d, mf6_input, mshape, idt, nc_vars, & input_fname) - ! -- dummy integer(I4B), dimension(:, :), contiguous, pointer, intent(in) :: int2d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape type(InputParamDefinitionType), intent(in) :: idt type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: k integer(I4B) :: ncpl, nlay, varid integer(I4B), dimension(:), contiguous, pointer :: int1d_ptr - ! + nullify (int1d_ptr) if (size(mshape) == 3) then @@ -406,16 +358,12 @@ subroutine load_integer2d_layered(int2d, mf6_input, mshape, idt, nc_vars, & nc_vars%nc_fname) end do end if - ! - ! -- return - return end subroutine load_integer2d_layered !> @brief load type 3d integer !< subroutine load_integer3d_type(int3d, mf6_input, mshape, idt, nc_vars, varid, & input_fname) - ! -- dummy integer(I4B), dimension(:, :, :), contiguous, pointer, intent(in) :: int3d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -423,38 +371,30 @@ subroutine load_integer3d_type(int3d, mf6_input, mshape, idt, nc_vars, varid, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars integer(I4B), intent(in) :: varid character(len=*), intent(in) :: input_fname - ! -- local - ! call nf_verify(nf90_get_var(nc_vars%ncid, varid, int3d), nc_vars%nc_fname) - ! - return end subroutine load_integer3d_type !> @brief load type 3d integer layered !< subroutine load_integer3d_layered(int3d, mf6_input, mshape, idt, nc_vars, & input_fname) - ! -- dummy integer(I4B), dimension(:, :, :), contiguous, pointer, intent(in) :: int3d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape type(InputParamDefinitionType), intent(in) :: idt type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: k !, i, j integer(I4B) :: ncpl, nlay, varid integer(I4B) :: index_start, index_stop integer(I4B), dimension(:), contiguous, pointer :: int1d_ptr - ! + nullify (int1d_ptr) index_start = 1 - ! call get_layered_shape(mshape, nlay, layer_shape) - ! ncpl = product(layer_shape) - ! + do k = 1, nlay varid = nc_vars%varid(idt%mf6varname, layer=k) index_stop = index_start + ncpl - 1 @@ -463,16 +403,12 @@ subroutine load_integer3d_layered(int3d, mf6_input, mshape, idt, nc_vars, & nc_vars%nc_fname) index_start = index_stop + 1 end do - ! - ! -- return - return end subroutine load_integer3d_layered !> @brief load type 1d double !< subroutine load_double1d_type(dbl1d, mf6_input, mshape, idt, nc_vars, & varid, input_fname) - ! -- dummy real(DP), dimension(:), contiguous, pointer, intent(in) :: dbl1d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -480,19 +416,17 @@ subroutine load_double1d_type(dbl1d, mf6_input, mshape, idt, nc_vars, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars integer(I4B), intent(in) :: varid character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: array_shape real(DP), dimension(:, :, :), contiguous, pointer :: dbl3d_ptr real(DP), dimension(:, :), contiguous, pointer :: dbl2d_ptr integer(I4B) :: nvals - ! - ! -- initialize + + ! initialize nvals = 0 - ! + if (idt%shape == 'NODES') then - ! -- set number of values + ! set number of values nvals = product(mshape) - ! if (size(mshape) == 3) then dbl3d_ptr(1:mshape(3), 1:mshape(2), 1:mshape(1)) => dbl1d(1:nvals) call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl3d_ptr), & @@ -505,18 +439,13 @@ subroutine load_double1d_type(dbl1d, mf6_input, mshape, idt, nc_vars, & call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl1d), nc_vars%nc_fname) end if else - ! -- interpret shape + ! interpret shape call get_shape_from_string(idt%shape, array_shape, mf6_input%mempath) - ! - ! -- set nvals + ! set nvals nvals = array_shape(1) - ! - ! -- read and set data + ! read and set data call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl1d), nc_vars%nc_fname) end if - ! - ! -- return - return end subroutine load_double1d_type !> @brief load type 1d double @@ -524,7 +453,6 @@ end subroutine load_double1d_type subroutine load_double1d_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & iper, input_fname, iaux) use ConstantsModule, only: DNODATA - ! -- dummy real(DP), dimension(:), contiguous, pointer, intent(in) :: dbl1d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -533,21 +461,20 @@ subroutine load_double1d_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & integer(I4B), intent(in) :: iper character(len=*), intent(in) :: input_fname integer(I4B), optional, intent(in) :: iaux - ! -- local real(DP), dimension(:, :, :), contiguous, pointer :: dbl3d integer(I4B) :: nvals, varid integer(I4B) :: n, i, j, k - ! - ! -- initialize + + ! initialize nvals = 0 - ! - ! -- set varid + + ! set varid if (present(iaux)) then varid = nc_vars%varid(idt%mf6varname, period=iper, iaux=iaux) else varid = nc_vars%varid(idt%mf6varname, period=iper) end if - ! + if (idt%shape == 'NODES') then ! TODO future support write (errmsg, '(a)') & @@ -558,12 +485,9 @@ subroutine load_double1d_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & else if (idt%shape == 'NCPL' .or. idt%shape == 'NAUX NCPL') then if (size(mshape) == 3) then - ! allocate (dbl3d(mshape(3), mshape(2), mshape(1))) - ! call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl3d), & nc_vars%nc_fname) - ! n = 0 do k = 1, size(dbl3d, dim=3) do i = 1, size(dbl3d, dim=2) @@ -595,27 +519,23 @@ end subroutine load_double1d_spd !< subroutine load_double1d_layered(dbl1d, mf6_input, mshape, idt, nc_vars, & input_fname) - ! -- dummy real(DP), dimension(:), contiguous, pointer, intent(in) :: dbl1d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape type(InputParamDefinitionType), intent(in) :: idt type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: nlay, varid integer(I4B) :: k, ncpl integer(I4B) :: index_start, index_stop real(DP), dimension(:), contiguous, pointer :: dbl1d_ptr - ! + nullify (dbl1d_ptr) index_start = 1 - ! call get_layered_shape(mshape, nlay, layer_shape) - ! ncpl = product(layer_shape) - ! + do k = 1, nlay varid = nc_vars%varid(idt%mf6varname, layer=k) index_stop = index_start + ncpl - 1 @@ -624,9 +544,6 @@ subroutine load_double1d_layered(dbl1d, mf6_input, mshape, idt, nc_vars, & nc_vars%nc_fname) index_start = index_stop + 1 end do - ! - ! -- return - return end subroutine load_double1d_layered !> @brief load type 1d double layered @@ -634,7 +551,6 @@ end subroutine load_double1d_layered subroutine load_double1d_layered_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & iper, input_fname, iaux) use ConstantsModule, only: DNODATA - ! -- dummy real(DP), dimension(:), contiguous, pointer, intent(in) :: dbl1d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -643,18 +559,16 @@ subroutine load_double1d_layered_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & integer(I4B), intent(in) :: iper character(len=*), intent(in) :: input_fname integer(I4B), optional, intent(in) :: iaux - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: nlay, varid integer(I4B) :: k, n, ncpl integer(I4B) :: index_start, index_stop real(DP), dimension(:), contiguous, pointer :: dbl1d_ptr - ! + call get_layered_shape(mshape, nlay, layer_shape) - ! ncpl = product(layer_shape) allocate (dbl1d_ptr(ncpl)) - ! + do k = 1, nlay index_start = 1 index_stop = index_start + ncpl - 1 @@ -671,19 +585,15 @@ subroutine load_double1d_layered_spd(dbl1d, mf6_input, mshape, idt, nc_vars, & end if end do end do - ! - ! -- cleanup + + ! cleanup deallocate (dbl1d_ptr) - ! - ! -- return - return end subroutine load_double1d_layered_spd !> @brief load type 2d double !< subroutine load_double2d_type(dbl2d, mf6_input, mshape, idt, nc_vars, varid, & input_fname) - ! -- dummy real(DP), dimension(:, :), contiguous, pointer, intent(in) :: dbl2d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -691,13 +601,12 @@ subroutine load_double2d_type(dbl2d, mf6_input, mshape, idt, nc_vars, varid, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars integer(I4B), intent(in) :: varid character(len=*), intent(in) :: input_fname - ! -- local real(DP), dimension(:), contiguous, pointer :: dbl1d_ptr integer(I4B), dimension(:), allocatable :: array_shape integer(I4B) :: ncpl, nlay - ! + nullify (dbl1d_ptr) - ! + if (nc_vars%grid == 'STRUCTURED') then call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl2d), nc_vars%nc_fname) else if (nc_vars%grid == 'LAYERED MESH') then @@ -707,28 +616,23 @@ subroutine load_double2d_type(dbl2d, mf6_input, mshape, idt, nc_vars, varid, & call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl1d_ptr), & nc_vars%nc_fname) end if - ! - ! -- return - return end subroutine load_double2d_type !> @brief load type 2d double layered !< subroutine load_double2d_layered(dbl2d, mf6_input, mshape, idt, nc_vars, & input_fname) - ! -- dummy real(DP), dimension(:, :), contiguous, pointer, intent(in) :: dbl2d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape type(InputParamDefinitionType), intent(in) :: idt type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: k integer(I4B) :: ncpl, nlay, varid real(DP), dimension(:), contiguous, pointer :: dbl1d_ptr - ! + nullify (dbl1d_ptr) if (size(mshape) == 3) then @@ -747,16 +651,12 @@ subroutine load_double2d_layered(dbl2d, mf6_input, mshape, idt, nc_vars, & nc_vars%nc_fname) end do end if - ! - ! -- return - return end subroutine load_double2d_layered !> @brief load type 3d double !< subroutine load_double3d_type(dbl3d, mf6_input, mshape, idt, nc_vars, varid, & input_fname) - ! -- dummy real(DP), dimension(:, :, :), contiguous, pointer, intent(in) :: dbl3d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape @@ -764,31 +664,26 @@ subroutine load_double3d_type(dbl3d, mf6_input, mshape, idt, nc_vars, varid, & type(NCPackageVarsType), pointer, intent(in) :: nc_vars integer(I4B), intent(in) :: varid character(len=*), intent(in) :: input_fname - ! -- local ! call nf_verify(nf90_get_var(nc_vars%ncid, varid, dbl3d), nc_vars%nc_fname) - ! - return end subroutine load_double3d_type !> @brief load type 3d double layered !< subroutine load_double3d_layered(dbl3d, mf6_input, mshape, idt, nc_vars, & input_fname) - ! -- dummy real(DP), dimension(:, :, :), contiguous, pointer, intent(in) :: dbl3d type(ModflowInputType), intent(in) :: mf6_input integer(I4B), dimension(:), contiguous, pointer, intent(in) :: mshape type(InputParamDefinitionType), intent(in) :: idt type(NCPackageVarsType), pointer, intent(in) :: nc_vars character(len=*), intent(in) :: input_fname - ! -- local integer(I4B), dimension(:), allocatable :: layer_shape integer(I4B) :: k !, i, j integer(I4B) :: ncpl, nlay, varid integer(I4B) :: index_start, index_stop real(DP), dimension(:), contiguous, pointer :: dbl1d_ptr - ! + nullify (dbl1d_ptr) call get_layered_shape(mshape, nlay, layer_shape) @@ -803,9 +698,6 @@ subroutine load_double3d_layered(dbl3d, mf6_input, mshape, idt, nc_vars, & nc_vars%nc_fname) index_start = index_stop + 1 end do - ! - ! -- return - return end subroutine load_double3d_layered end module NCArrayReaderModule diff --git a/src/Utilities/Idm/netcdf/NCContextBuild.f90 b/src/Utilities/Idm/netcdf/NCContextBuild.f90 index 7ded2b6b591..1340f6ae516 100644 --- a/src/Utilities/Idm/netcdf/NCContextBuild.f90 +++ b/src/Utilities/Idm/netcdf/NCContextBuild.f90 @@ -24,101 +24,88 @@ module NCContextBuildModule !> @brief open netcdf file !< function open_ncfile(nc_fname, iout) result(ncid) - ! -- modules use MemoryManagerExtModule, only: mem_set_value use NetCDFCommonModule, only: nc_fopen - ! -- dummy character(len=*) :: nc_fname integer(I4B) :: iout - ! -- result integer(I4B) :: ncid - ! -- local logical(LGP) :: exists - ! - ! -- initialize + + ! initialize ncid = 0 - ! - ! -- check if NETCDF file exists + + ! check if NETCDF file exists inquire (file=nc_fname, exist=exists) if (.not. exists) then write (errmsg, '(a,a,a)') 'Specified NetCDF input file does & ¬ exist [file=', trim(nc_fname), '].' call store_error(errmsg, .true.) end if - ! - ! -- open + + ! open ncid = nc_fopen(nc_fname, iout) - ! - ! -- return - return end function open_ncfile !> @brief add a package input variable to nc_vars structure !< subroutine add_package_var(modeltype, modelname, nc_vars, input_name, varid, & iout) - ! -- modules use InputOutputModule, only: lowcase, upcase use MemoryHelperModule, only: split_mem_address, split_mem_path use SourceCommonModule, only: idm_subcomponent_type use SourceCommonModule, only: idm_subcomponent_name - ! -- dummy character(len=*), intent(in) :: modeltype character(len=*), intent(in) :: modelname type(NCFileVarsType), intent(inout) :: nc_vars character(len=*), intent(in) :: input_name integer(I4B), intent(in) :: varid integer(I4B), intent(in) :: iout - ! -- local character(len=NETCDF_ATTR_STRLEN) :: input_str character(len=LENCOMPONENTNAME) :: c_name, sc_name character(len=LINELENGTH) :: mempath, varname integer(I4B) :: layer, period, iaux, mf6_layer, mf6_period, mf6_iaux logical(LGP) :: success - ! - ! -- initialize + + ! initialize layer = -1 period = -1 iaux = -1 varname = '' c_name = '' sc_name = '' - ! - ! -- process mf6_input attribute + + ! process mf6_input attribute if (nf90_get_att(nc_vars%ncid, varid, 'modflow6_input', & input_str) == NF90_NOERR) then - ! - ! -- mf6_input should provide a memory address + ! mf6_input should provide a memory address call split_mem_address(input_str, mempath, varname, success) - ! + if (success) then - ! -- split the mempath + ! split the mempath call split_mem_path(mempath, c_name, sc_name) - ! - ! -- set read tokens to upper case + ! set read tokens to upper case call upcase(varname) call upcase(c_name) call upcase(sc_name) - ! - ! -- check for optional layer attribute + ! check for optional layer attribute if (nf90_get_att(nc_vars%ncid, varid, & 'modflow6_layer', mf6_layer) == NF90_NOERR) then layer = mf6_layer end if - ! - ! -- check for optional period attribute + + ! check for optional period attribute if (nf90_get_att(nc_vars%ncid, varid, & 'modflow6_iper', mf6_period) == NF90_NOERR) then period = mf6_period end if - ! - ! -- check for optional period attribute + + ! check for optional period attribute if (nf90_get_att(nc_vars%ncid, varid, & 'modflow6_iaux', mf6_iaux) == NF90_NOERR) then iaux = mf6_iaux end if - ! - ! -- add the variable to netcdf description + + ! add the variable to netcdf description call nc_vars%add(sc_name, varname, layer, period, iaux, varid) else errmsg = 'NetCDF variable invalid modflow6_input attribute: "'// & @@ -127,9 +114,6 @@ subroutine add_package_var(modeltype, modelname, nc_vars, input_name, varid, & call store_error_filename(nc_vars%nc_fname) end if end if - ! - ! -- return - return end subroutine add_package_var !> @brief verify global attribute modflow6_grid is present and return value @@ -137,34 +121,26 @@ end subroutine add_package_var function verify_global_attr(modeltype, modelname, input_name, nc_fname, ncid) & result(grid) use InputOutputModule, only: lowcase, upcase - ! -- dummy character(len=*), intent(in) :: modeltype character(len=*), intent(in) :: modelname character(len=*), intent(in) :: input_name character(len=*), intent(in) :: nc_fname integer(I4B), intent(in) :: ncid - ! -- result character(len=NETCDF_ATTR_STRLEN) :: grid - ! - ! -- initialize grid + + ! initialize grid grid = '' - ! - ! -- verify expected mf6_modeltype file attribute + + ! verify expected mf6_modeltype file attribute if (nf90_get_att(ncid, NF90_GLOBAL, "modflow6_grid", & grid) == NF90_NOERR) then - ! - ! -- set grid to upper case + ! set grid to upper case call upcase(grid) - ! else errmsg = 'NetCDF input file global attribute "grid" not found.' call store_error(errmsg) call store_error_filename(nc_fname) - ! end if - ! - ! -- return - return end function verify_global_attr !> @brief create internal description of modflow6 input variables in netcdf file @@ -181,37 +157,30 @@ subroutine create_netcdf_context(modeltype, modelname, input_name, & integer(I4B), intent(in) :: iout integer(I4B) :: ndim, nvar, nattr, unlimDimID integer(I4B), dimension(:), allocatable :: varids - ! -- local character(len=LINELENGTH) :: grid integer(I4B) :: iparam - ! - ! -- check global attributes + + ! check global attributes grid = verify_global_attr(modeltype, modelname, input_name, nc_fname, ncid) - ! - ! -- initialize netcdf input structure + + ! initialize netcdf input structure call nc_vars%init(modelname, nc_fname, ncid, grid) - ! - ! -- inquire for root dataset info + + ! inquire for root dataset info call nf_verify(nf90_inquire(ncid, ndim, nvar, nattr, unlimdimid), & nc_vars%nc_fname) - ! - ! -- allocate and set varids + + ! allocate and set varids allocate (varids(nvar)) call nf_verify(nf90_inq_varids(ncid, nvar, varids), nc_vars%nc_fname) - ! do iparam = 1, nvar - ! - ! -- validate and add netcdf file input variable + ! validate and add netcdf file input variable call add_package_var(modeltype, modelname, nc_vars, input_name, & varids(iparam), iout) - ! end do - ! - ! -- cleanup + + ! cleanup deallocate (varids) - ! - ! -- return - return end subroutine create_netcdf_context end module NCContextBuildModule diff --git a/src/Utilities/Idm/netcdf/NCFileVars.f90 b/src/Utilities/Idm/netcdf/NCFileVars.f90 index d7cd82cbcc9..a7cee0273d1 100644 --- a/src/Utilities/Idm/netcdf/NCFileVars.f90 +++ b/src/Utilities/Idm/netcdf/NCFileVars.f90 @@ -62,55 +62,44 @@ module NCFileVarsModule !> @brief create netcdf package variable lists !< subroutine ncvars_init(this, modelname) - ! -- modules - ! -- dummy class(NCPackageVarsType) :: this character(len=*), intent(in) :: modelname - ! -- local - ! - ! -- set modelname + ! set modelname this%modelname = modelname - ! - ! -- return - return end subroutine ncvars_init !> @brief return a netcdf variable id for a package tagname !< function ncvars_varid(this, tagname, layer, period, iaux) result(varid) - ! -- modules - ! -- dummy class(NCPackageVarsType) :: this character(len=*), intent(in) :: tagname integer(I4B), optional :: layer integer(I4B), optional :: period integer(I4B), optional :: iaux - ! -- return integer(I4B) :: varid - ! -- local integer(I4B) :: n, l, p, a class(NCFileMf6VarType), pointer :: nc_var - ! - ! -- initialize + + ! initialize varid = -1 l = -1 p = -1 a = -1 - ! - ! -- set search layer if provided + + ! set search layer if provided if (present(layer)) then l = layer end if - ! - ! -- set search period if provided + + ! set search period if provided if (present(period)) then p = period end if - ! -- set search iaux if provided + ! set search iaux if provided if (present(iaux)) then a = iaux end if - ! + do n = 1, this%nc_vars%Count() nc_var => ncvar_get(this%nc_vars, n) if (nc_var%tagname == tagname .and. & @@ -120,8 +109,8 @@ function ncvars_varid(this, tagname, layer, period, iaux) result(varid) varid = nc_var%varid end if end do - ! - ! -- set error and exit if variable not in NetCDF input + + ! set error and exit if variable not in NetCDF input if (varid == -1) then if (this%nc_fname /= '') then write (errmsg, '(a)') & @@ -145,78 +134,59 @@ function ncvars_varid(this, tagname, layer, period, iaux) result(varid) call store_error(errmsg, .true.) end if end if - ! - ! -- return - return end function ncvars_varid !> @brief destroy netcdf package variable lists !< subroutine ncvars_destroy(this) - ! -- modules - ! -- dummy class(NCPackageVarsType) :: this - ! -- local class(NCFileMf6VarType), pointer :: nc_var integer(I4B) :: n - ! - ! -- deallocate allocated memory + ! deallocate allocated memory do n = 1, this%nc_vars%Count() nc_var => ncvar_get(this%nc_vars, n) deallocate (nc_var) nullify (nc_var) end do - ! call this%nc_vars%Clear() - ! - ! -- return - return end subroutine ncvars_destroy !> @brief initialize netcdf model variable description type !< subroutine fv_init(this, modelname, nc_fname, ncid, grid) - ! -- modules use ConstantsModule, only: LENMEMPATH use MemoryManagerModule, only: mem_allocate use MemoryHelperModule, only: create_mem_path use SimVariablesModule, only: idm_context - ! -- dummy variables class(NCFileVarsType) :: this character(len=*), intent(in) :: modelname character(len=*), intent(in) :: nc_fname integer(I4B), intent(in) :: ncid character(len=*), intent(in) :: grid - ! -- local variables character(len=LENMEMPATH) :: mempath integer(I4B) :: ilen - ! - ! -- set mempath + + ! set mempath mempath = create_mem_path(component=modelname, & context=idm_context) - ! -- initialize strlen + ! initialize strlen ilen = LINELENGTH - ! - ! -- allocate managed memory + + ! allocate managed memory call mem_allocate(this%grid, ilen, 'NETCDF_GRID', mempath) call mem_allocate(this%nc_fname, ilen, 'NETCDF_FNAME', mempath) call mem_allocate(this%ncid, 'NCID', mempath) - ! - ! -- set + + ! set this%grid = grid this%nc_fname = nc_fname this%ncid = ncid - ! - ! -- return - return end subroutine fv_init !> @brief add netcdf modflow6 input variable to list !< subroutine fv_add(this, pkgname, tagname, layer, period, iaux, varid) - ! -- modules use ArrayHandlersModule, only: expandarray - ! -- dummy variables class(NCFileVarsType) :: this character(len=*), intent(in) :: pkgname character(len=*), intent(in) :: tagname @@ -224,11 +194,9 @@ subroutine fv_add(this, pkgname, tagname, layer, period, iaux, varid) integer(I4B), intent(in) :: period integer(I4B), intent(in) :: iaux integer(I4B), intent(in) :: varid - ! -- local variables class(NCFileMf6VarType), pointer :: invar class(*), pointer :: obj - ! - ! -- add mf6 variable to file list + ! add mf6 variable to file list allocate (invar) invar%pkgname = pkgname invar%tagname = tagname @@ -236,52 +204,39 @@ subroutine fv_add(this, pkgname, tagname, layer, period, iaux, varid) invar%period = period invar%iaux = iaux invar%varid = varid - ! obj => invar call this%mf6invar%Add(obj) - ! - ! -- return - return end subroutine fv_add !> @brief destroy netcdf model variable description type !< subroutine fv_destroy(this) - ! -- modules - ! -- dummy class(NCFileVarsType) :: this class(NCFileMf6VarType), pointer :: invar integer(I4B) :: n - ! do n = 1, this%mf6invar%Count() invar => ncvar_get(this%mf6invar, n) deallocate (invar) nullify (invar) end do - ! call this%mf6invar%Clear() - ! - return end subroutine fv_destroy !> @brief create list of variables that correspond to a package !< subroutine create_varlists(this, modelname, pkgname, nc_vars) - ! -- modules - ! -- dummy class(NCFileVarsType) :: this character(len=*), intent(in) :: modelname character(len=*), intent(in) :: pkgname type(NCPackageVarsType), pointer, intent(inout) :: nc_vars integer(I4B) :: n - ! -- local class(NCFileMf6VarType), pointer :: invar, nc_var class(*), pointer :: obj - ! + do n = 1, this%mf6invar%count() invar => ncvar_get(this%mf6invar, n) if (invar%pkgname == pkgname) then - ! -- create package variable description + ! create package variable description allocate (nc_var) nc_var%pkgname = invar%pkgname nc_var%tagname = invar%tagname @@ -293,33 +248,28 @@ subroutine create_varlists(this, modelname, pkgname, nc_vars) call nc_vars%nc_vars%Add(obj) end if end do - ! - ! -- set modelname + + ! set modelname nc_vars%modelname = modelname - ! - ! -- set file attribute pointers + + ! set file attribute pointers nc_vars%ncid => this%ncid nc_vars%nc_fname => this%nc_fname nc_vars%grid => this%grid - ! - ! -- return - return end subroutine create_varlists !> @brief get modflow6 input variable description at position idx !< function ncvar_get(nc_vars, idx) result(res) - ! -- dummy variables type(ListType) :: nc_vars integer(I4B), intent(in) :: idx !< package number class(NCFileMf6VarType), pointer :: res - ! -- local variables class(*), pointer :: obj - ! - ! -- initialize res + + ! initialize res res => null() - ! - ! -- get the package from the list + + ! get the package from the list obj => nc_vars%GetItem(idx) if (associated(obj)) then select type (obj) @@ -327,9 +277,6 @@ function ncvar_get(nc_vars, idx) result(res) res => obj end select end if - ! - ! -- return - return end function ncvar_get end module NCFileVarsModule diff --git a/src/Utilities/Idm/netcdf/NetCDFCommon.f90 b/src/Utilities/Idm/netcdf/NetCDFCommon.f90 index 372eeafcc24..42bf9953d3a 100644 --- a/src/Utilities/Idm/netcdf/NetCDFCommon.f90 +++ b/src/Utilities/Idm/netcdf/NetCDFCommon.f90 @@ -28,14 +28,10 @@ module NetCDFCommonModule function nc_fopen(nc_fname, iout) result(ncid) character(len=*), intent(in) :: nc_fname integer(I4B), intent(in) :: iout - ! -- return integer(I4B) :: ncid - ! -- local - ! - ! -- initialize + ! initialize ncid = -1 - ! - ! -- open netcdf file + ! open netcdf file call nf_verify(nf90_open(nc_fname, NF90_NOWRITE, ncid), nc_fname) end function nc_fopen @@ -44,9 +40,7 @@ end function nc_fopen subroutine nc_fclose(ncid, nc_fname) integer(I4B), intent(in) :: ncid character(len=*), intent(in) :: nc_fname - ! -- local - ! - ! -- close netcdf file + ! close netcdf file call nf_verify(nf90_close(ncid), nc_fname) end subroutine nc_fclose @@ -55,11 +49,10 @@ end subroutine nc_fclose subroutine nf_verify(res, nc_fname) integer(I4B), intent(in) :: res character(len=*), intent(in) :: nc_fname - ! -- local variables character(len=LINELENGTH) :: errstr - ! - ! -- strings are set for a subset of errors - ! but the exit status will always be reported + + ! strings are set for a subset of errors + ! but the exit status will always be reported if (res /= NF90_NOERR) then ! select case (res) @@ -100,7 +93,7 @@ subroutine nf_verify(res, nc_fname) case default errstr = '' end select - ! + if (errstr /= '') then write (errmsg, '(a,a,a,i0,a)') 'NetCDF library error [error="', & trim(errstr), '", exit code=', res, '].' @@ -108,7 +101,7 @@ subroutine nf_verify(res, nc_fname) write (errmsg, '(a,i0,a)') 'NetCDF library error [exit code=', & res, '].' end if - ! + call store_error(errmsg) call store_error_filename(nc_fname) end if