diff --git a/config_src/coupled_driver/MOM_surface_forcing.F90 b/config_src/coupled_driver/MOM_surface_forcing.F90 index ce699b1397..a76d37cd6e 100644 --- a/config_src/coupled_driver/MOM_surface_forcing.F90 +++ b/config_src/coupled_driver/MOM_surface_forcing.F90 @@ -352,7 +352,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, G, CS, & open_ocn_mask(:,:) = 1.0 if (CS%mask_srestore_under_ice) then ! Do not restore under sea-ice do j=js,je ; do i=is,ie - if (sfc_state%SST(i,j) .le. -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 + if (sfc_state%SST(i,j) <= -0.0539*sfc_state%SSS(i,j)) open_ocn_mask(i,j)=0.0 enddo; enddo endif if (CS%salt_restore_as_sflux) then @@ -1009,7 +1009,7 @@ subroutine surface_forcing_init(Time, G, param_file, diag, CS, restore_salt, res CS%diag => diag - call write_version_number (version) + call write_version_number(version) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") diff --git a/config_src/coupled_driver/ocean_model_MOM.F90 b/config_src/coupled_driver/ocean_model_MOM.F90 index af4dddbadb..dca6b8a837 100644 --- a/config_src/coupled_driver/ocean_model_MOM.F90 +++ b/config_src/coupled_driver/ocean_model_MOM.F90 @@ -818,7 +818,7 @@ subroutine initialize_ocean_public_type(input_domain, Ocean_sfc, diag, maskmap, call mpp_get_layout(input_domain,layout) call mpp_get_global_domain(input_domain, xsize=xsz, ysize=ysz) - if(PRESENT(maskmap)) then + if (PRESENT(maskmap)) then call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain, maskmap=maskmap) else call mpp_define_domains((/1,xsz,1,ysz/),layout,Ocean_sfc%Domain) diff --git a/config_src/solo_driver/MOM_driver.F90 b/config_src/solo_driver/MOM_driver.F90 index 1bc713d106..2727f42e1f 100644 --- a/config_src/solo_driver/MOM_driver.F90 +++ b/config_src/solo_driver/MOM_driver.F90 @@ -104,7 +104,7 @@ program MOM_main ! simulation does not exceed its CPU time limit. nmax is determined by ! evaluating the CPU time used between successive calls to write_cputime. ! Initially it is set to be very large. - integer :: nmax=2000000000; + integer :: nmax=2000000000 ! A structure containing several relevant directory paths. type(directories) :: dirs diff --git a/config_src/solo_driver/Neverland_surface_forcing.F90 b/config_src/solo_driver/Neverland_surface_forcing.F90 index 588fa5fde8..972132ae6a 100644 --- a/config_src/solo_driver/Neverland_surface_forcing.F90 +++ b/config_src/solo_driver/Neverland_surface_forcing.F90 @@ -73,23 +73,23 @@ subroutine Neverland_wind_forcing(sfc_state, forces, day, G, CS) ! The i-loop extends to is-1 so that taux can be used later in the ! calculation of ustar - otherwise the lower bound would be Isq. - PI = 4.0*atan(1.0) - forces%taux(:,:) = 0.0 - tau_max = 0.2 - off = 0.02 + PI = 4.0*atan(1.0) + forces%taux(:,:) = 0.0 + tau_max = 0.2 + off = 0.02 do j=js,je ; do I=is-1,Ieq -! x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat -! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 +! x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat +! forces%taux(I,j) = G%mask2dCu(I,j) * 0.0 - if (y.le.0.29) then - forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) + if (y <= 0.29) then + forces%taux(I,j) = forces%taux(I,j) + tau_max * ( (1/0.29)*y - ( 1/(2*PI) )*sin( (2*PI*y) / 0.29 ) ) endif - if (y.gt.0.29 .and. y.le.(0.8-off)) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) + if ((y > 0.29) .and. (y <= (0.8-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *(0.35+0.65*cos(PI*(y-0.29)/(0.51-off)) ) endif - if (y.gt.(0.8-off) .and. y.le.(1-off) ) then - forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) + if ((y > (0.8-off)) .and. (y <= (1-off))) then + forces%taux(I,j) = forces%taux(I,j) + tau_max *( 1.5*( (y-1+off) - (0.1/PI)*sin(10.0*PI*(y-0.8+off)) ) ) endif enddo ; enddo diff --git a/config_src/solo_driver/coupler_types.F90 b/config_src/solo_driver/coupler_types.F90 index ba4ce0d3fa..99a74e085c 100644 --- a/config_src/solo_driver/coupler_types.F90 +++ b/config_src/solo_driver/coupler_types.F90 @@ -314,7 +314,7 @@ subroutine coupler_type_copy_1d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_2d @@ -365,7 +365,7 @@ subroutine coupler_type_copy_1d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_1d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_1d_3d @@ -408,7 +408,7 @@ subroutine coupler_type_copy_2d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_2d @@ -459,7 +459,7 @@ subroutine coupler_type_copy_2d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_2d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_2d_3d @@ -502,7 +502,7 @@ subroutine coupler_type_copy_3d_2d(var_in, var_out, is, ie, js, je, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_2d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_2d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_2d @@ -553,7 +553,7 @@ subroutine coupler_type_copy_3d_3d(var_in, var_out, is, ie, js, je, kd, & if (var_in%num_bcs >= 0) & call CT_spawn_3d_3d(var_in, var_out, (/ is, is, ie, ie /), (/ js, js, je, je /), (/1, kd/), suffix) - if ((var_out%num_bcs > 0) .and. (diag_name .ne. ' ')) & + if ((var_out%num_bcs > 0) .and. (diag_name /= ' ')) & call CT_set_diags_3d(var_out, diag_name, axes, time) end subroutine coupler_type_copy_3d_3d diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index c39dbec562..e4d297ddc8 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -361,12 +361,10 @@ subroutine ALE_main( G, GV, h, u, v, tv, Reg, CS, dt, frac_shelf_h) ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(isc,iec,jsc,jec,nk,h,h_new,CS) - do k = 1,nk - do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo - enddo + !$OMP parallel do default(shared) + do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo if (CS%show_call_tree) call callTree_leave("ALE_main()") @@ -418,12 +416,10 @@ subroutine ALE_main_offline( G, GV, h, tv, Reg, CS, dt) ! Override old grid with new one. The new grid 'h_new' is built in ! one of the 'build_...' routines above. -!$OMP parallel do default(none) shared(isc,iec,jsc,jec,nk,h,h_new,CS) - do k = 1,nk - do j = jsc-1,jec+1 ; do i = isc-1,iec+1 - h(i,j,k) = h_new(i,j,k) - enddo ; enddo - enddo + !$OMP parallel do default(shared) + do k = 1,nk ; do j = jsc-1,jec+1 ; do i = isc-1,iec+1 + h(i,j,k) = h_new(i,j,k) + enddo ; enddo ; enddo if (CS%show_call_tree) call callTree_leave("ALE_main()") if (CS%id_dzRegrid>0 .and. present(dt)) call post_data(CS%id_dzRegrid, dzRegrid, CS%diag) @@ -494,7 +490,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug) endif call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), 0., Kd(i,j,:)) endif - enddo ; enddo; + enddo ; enddo call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%T, h_new, tv%T) call ALE_remap_scalar(CS%remapCS, G, GV, nk, h, tv%S, h_new, tv%S) @@ -651,7 +647,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n, u, v, Reg, dt, dzRegrid, integer :: i, j, k, nz type(thermo_var_ptrs) :: tv_local ! local/intermediate temp/salt type(group_pass_type) :: pass_T_S_h ! group pass if the coordinate has a stencil - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thickesses + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_loc, h_orig ! A working copy of layer thicknesses real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T, S ! local temporary state ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v @@ -778,33 +774,29 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, !$OMP parallel do default(shared) private(h1,h2,u_column,Tr) do m=1,ntr ! For each tracer Tr => Reg%Tr(m) - do j = G%jsc,G%jec - do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - ! Build the start and final grids - h1(:) = h_old(i,j,:) - h2(:) = h_new(i,j,:) - call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - - ! Intermediate steps for tendency of tracer concentration and tracer content. - if (present(dt)) then - if (Tr%id_remap_conc>0) then - do k=1,GV%ke - work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k) ) * Idt - enddo - endif - if (Tr%id_remap_cont>0. .or. Tr%id_remap_cont_2d>0) then - do k=1,GV%ke - work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt - enddo - endif - endif - ! update tracer concentration - Tr%t(i,j,:) = u_column(:) + do j = G%jsc,G%jec ; do i = G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then + ! Build the start and final grids + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + call remapping_core_h(CS_remapping, nz, h1, Tr%t(i,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) + + ! Intermediate steps for tendency of tracer concentration and tracer content. + if (present(dt)) then + if (Tr%id_remap_conc>0) then + do k=1,GV%ke + work_conc(i,j,k) = (u_column(k) - Tr%t(i,j,k) ) * Idt + enddo + endif + if (Tr%id_remap_cont>0. .or. Tr%id_remap_cont_2d>0) then + do k=1,GV%ke + work_cont(i,j,k) = (u_column(k)*h2(k) - Tr%t(i,j,k)*h1(k)) * Idt + enddo endif - enddo ! i - enddo ! j + endif + ! update tracer concentration + Tr%t(i,j,:) = u_column(:) + endif ; enddo ; enddo ! tendency diagnostics. if (Tr%id_remap_conc > 0) then @@ -814,14 +806,12 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, call post_data(Tr%id_remap_cont, work_cont, CS_ALE%diag) endif if (Tr%id_remap_cont_2d > 0) then - do j = G%jsc,G%jec - do i = G%isc,G%iec - work_2d(i,j) = 0.0 - do k = 1,GV%ke - work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) - enddo + do j = G%jsc,G%jec ; do i = G%isc,G%iec + work_2d(i,j) = 0.0 + do k = 1,GV%ke + work_2d(i,j) = work_2d(i,j) + work_cont(i,j,k) enddo - enddo + enddo ; enddo call post_data(Tr%id_remap_cont_2d, work_2d, CS_ALE%diag) endif @@ -834,25 +824,21 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap u velocity component if ( present(u) ) then !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - do j = G%jsc,G%jec - do I = G%iscB,G%iecB - if (G%mask2dCu(I,j)>0.) then - ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) - if (CS_ALE%remap_uv_using_old_alg) then - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) - endif - call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - u(I,j,:) = u_column(:) - endif - enddo - enddo + do j = G%jsc,G%jec ; do I = G%iscB,G%iecB ; if (G%mask2dCu(I,j)>0.) then + ! Build the start and final grids + h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i+1,j,:) ) + if (CS_ALE%remap_uv_using_old_alg) then + dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i+1,j,:) ) + do k = 1, nz + h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) + enddo + else + h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i+1,j,:) ) + endif + call remapping_core_h(CS_remapping, nz, h1, u(I,j,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) + u(I,j,:) = u_column(:) + endif ; enddo ; enddo endif if (show_call_tree) call callTree_waypoint("u remapped (remap_all_state_vars)") @@ -860,25 +846,21 @@ subroutine remap_all_state_vars(CS_remapping, CS_ALE, G, GV, h_old, h_new, Reg, ! Remap v velocity component if ( present(v) ) then !$OMP parallel do default(shared) private(h1,h2,dx,u_column) - do J = G%jscB,G%jecB - do i = G%isc,G%iec - if (G%mask2dCv(i,j)>0.) then - ! Build the start and final grids - h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) - if (CS_ALE%remap_uv_using_old_alg) then - dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) - enddo - else - h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) - endif - call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & - u_column, h_neglect, h_neglect_edge) - v(i,J,:) = u_column(:) - endif - enddo - enddo + do J = G%jscB,G%jecB ; do i = G%isc,G%iec ; if (G%mask2dCv(i,j)>0.) then + ! Build the start and final grids + h1(:) = 0.5 * ( h_old(i,j,:) + h_old(i,j+1,:) ) + if (CS_ALE%remap_uv_using_old_alg) then + dx(:) = 0.5 * ( dxInterface(i,j,:) + dxInterface(i,j+1,:) ) + do k = 1, nz + h2(k) = max( 0., h1(k) + ( dx(k+1) - dx(k) ) ) + enddo + else + h2(:) = 0.5 * ( h_new(i,j,:) + h_new(i,j+1,:) ) + endif + call remapping_core_h(CS_remapping, nz, h1, v(i,J,:), nz, h2, & + u_column, h_neglect, h_neglect_edge) + v(i,J,:) = u_column(:) + endif ; enddo ; enddo endif if (CS_ALE%id_vert_remap_h > 0) call post_data(CS_ALE%id_vert_remap_h, h_old, CS_ALE%diag) @@ -996,38 +978,36 @@ subroutine pressure_gradient_plm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! Determine reconstruction within each column !$OMP parallel do default(shared) private(hTmp,ppol_E,ppol_coefs,tmp) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) - end do - - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) - end do - - end do - end do + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + call PLM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PLM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo + + enddo ; enddo end subroutine pressure_gradient_plm @@ -1074,44 +1054,42 @@ subroutine pressure_gradient_ppm( CS, S_t, S_b, T_t, T_b, G, GV, tv, h, bdry_ext ! Determine reconstruction within each column !$OMP parallel do default(shared) private(hTmp,tmp,ppol_E,ppol_coefs) - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - - ! Build current grid - hTmp(:) = h(i,j,:) - tmp(:) = tv%S(i,j,:) - - ! Reconstruct salinity profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - S_t(i,j,k) = ppol_E(k,1) - S_b(i,j,k) = ppol_E(k,2) - end do - - ! Reconstruct temperature profile - ppol_E(:,:) = 0.0 - ppol_coefs(:,:) = 0.0 - tmp(:) = tv%T(i,j,:) - !### Try to replace the following value of h_neglect with GV%H_subroundoff. - call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) - call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - if (bdry_extrap) call & - PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) - - do k = 1,GV%ke - T_t(i,j,k) = ppol_E(k,1) - T_b(i,j,k) = ppol_E(k,2) - end do - - end do - end do + do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 + + ! Build current grid + hTmp(:) = h(i,j,:) + tmp(:) = tv%S(i,j,:) + + ! Reconstruct salinity profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=h_neglect_edge ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PPM_boundary_extrapolation( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + S_t(i,j,k) = ppol_E(k,1) + S_b(i,j,k) = ppol_E(k,2) + enddo + + ! Reconstruct temperature profile + ppol_E(:,:) = 0.0 + ppol_coefs(:,:) = 0.0 + tmp(:) = tv%T(i,j,:) + !### Try to replace the following value of h_neglect with GV%H_subroundoff. + call edge_values_implicit_h4( GV%ke, hTmp, tmp, ppol_E, h_neglect=1.0e-10*GV%m_to_H ) + call PPM_reconstruction( GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + if (bdry_extrap) & + call PPM_boundary_extrapolation(GV%ke, hTmp, tmp, ppol_E, ppol_coefs, h_neglect ) + + do k = 1,GV%ke + T_t(i,j,k) = ppol_E(k,1) + T_b(i,j,k) = ppol_E(k,2) + enddo + + enddo ; enddo end subroutine pressure_gradient_ppm diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index d4fe0a0c38..1f3488a7bc 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -694,7 +694,7 @@ subroutine check_grid_def(filename, varname, expected_units, msg, ierr) integer :: i ierr = .false. - status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid); + status = NF90_OPEN(trim(filename), NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then ierr = .true. msg = 'File not found: '//trim(filename) @@ -2149,19 +2149,19 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin) type(regridding_CS), intent(inout) :: CS !< Regridding control structure logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells - real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the new grid (m) - real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the new grid (m) + real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic (H units) real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic (H units) real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density - real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost SLight_nkml_min layers (m) - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickess layers at the top of the model + real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost SLight_nkml_min layers (m) + integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential !! density (m) real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find !! resolved stratification (nondim) - logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate + logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for !! spuriously unstable water mass profiles (m) real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index dee2e20bd8..10ba747d14 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -177,8 +177,7 @@ function isPosSumErrSignificant(n1, sum1, n2, sum2) endif end function isPosSumErrSignificant -!> Remaps column of values u0 on grid h0 to grid h1 -!! assuming the top edge is aligned. +!> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid @@ -197,7 +196,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefficients !Coefficients of polynomial + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k real :: eps, h0tot, h0err, h1tot, h1err, u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err real :: hNeglect, hNeglect_edge @@ -205,14 +204,14 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod, & + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod, & hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, h1, iMethod, & + call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & CS%force_bounds_in_subcell, u1, uh_err ) if (CS%check_remapping) then @@ -245,7 +244,7 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_ed enddo write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefficients(k,:) + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) enddo call MOM_error( FATAL, 'MOM_remapping, remapping_core_h: '//& 'Remapping result is inconsistent!' ) @@ -275,7 +274,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed integer :: iMethod real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefficients !Coefficients of polynomial + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k real :: eps, h0tot, h0err, h1tot, h1err real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err @@ -285,11 +284,11 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge - call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S, iMethod,& + call build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, ppoly_r_E, ppoly_r_S, iMethod,& hNeglect, hNeglect_edge ) if (CS%check_reconstruction) call check_reconstructions_1d(n0, h0, u0, CS%degree, & - CS%boundary_extrapolation, ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) + CS%boundary_extrapolation, ppoly_r_coefs, ppoly_r_E, ppoly_r_S) ! This is a temporary step prior to switching to remapping_core_h() do k = 1, n1 @@ -299,9 +298,9 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed h1(k) = max( 0., dx(k+1) - dx(k) ) endif enddo - call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, h1, iMethod, & + call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & CS%force_bounds_in_subcell,u1, uh_err ) -! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, n1, dx, iMethod, u1, hNeglect ) +! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) ! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) if (CS%check_remapping) then @@ -334,7 +333,7 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed enddo write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefficients(k,:) + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) enddo call MOM_error( FATAL, 'MOM_remapping, remapping_core_w: '//& 'Remapping result is inconsistent!' ) @@ -345,15 +344,15 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed end subroutine remapping_core_w !> Creates polynomial reconstructions of u0 on the source grid h0. -subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & +subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & ppoly_r_E, ppoly_r_S, iMethod, h_neglect, & h_neglect_edge ) - type(remapping_CS), intent(in) :: CS + type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid real, dimension(n0,CS%degree+1), & - intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + intent(out) :: ppoly_r_coefs !< Coefficients of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial integer, intent(out) :: iMethod !< Integration method @@ -371,7 +370,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & ! Reset polynomial ppoly_r_E(:,:) = 0.0 ppoly_r_S(:,:) = 0.0 - ppoly_r_coefficients(:,:) = 0.0 + ppoly_r_coefs(:,:) = 0.0 iMethod = -999 local_remapping_scheme = CS%remapping_scheme @@ -384,44 +383,44 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefficients, & endif select case ( local_remapping_scheme ) case ( REMAPPING_PCM ) - call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefficients) + call PCM_reconstruction( n0, u0, ppoly_r_E, ppoly_r_coefs) iMethod = INTEGRATION_PCM case ( REMAPPING_PLM ) - call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PLM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect) + call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect) end if iMethod = INTEGRATION_PLM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) end if iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_IH4 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) - call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then - call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefficients, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) end if iMethod = INTEGRATION_PPM case ( REMAPPING_PQM_IH4IH3 ) call edge_values_implicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call edge_slopes_implicit_h3( n0, h0, u0, ppoly_r_S, h_neglect ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & - ppoly_r_coefficients, h_neglect ) + ppoly_r_coefs, h_neglect ) end if iMethod = INTEGRATION_PQM case ( REMAPPING_PQM_IH6IH5 ) call edge_values_implicit_h6( n0, h0, u0, ppoly_r_E, h_neglect_edge ) call edge_slopes_implicit_h5( n0, h0, u0, ppoly_r_S, h_neglect ) - call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefficients, h_neglect ) + call PQM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_S, ppoly_r_coefs, h_neglect ) if ( CS%boundary_extrapolation ) then call PQM_boundary_extrapolation_v1( n0, h0, u0, ppoly_r_E, ppoly_r_S, & - ppoly_r_coefficients, h_neglect ) + ppoly_r_coefs, h_neglect ) end if iMethod = INTEGRATION_PQM case default @@ -433,13 +432,13 @@ end subroutine build_reconstructions_1d !> Checks that edge values and reconstructions satisfy bounds subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & - ppoly_r_coefficients, ppoly_r_E, ppoly_r_S) + ppoly_r_coefs, ppoly_r_E, ppoly_r_S) integer, intent(in) :: n0 !< Number of cells on source grid real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefficients !< Coefficients of polynomial + real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial ! Local variables @@ -490,11 +489,11 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & endif endif if (problem_detected) then - write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefficients(i0,:) + write(0,'(a,1p9e24.16)') 'Polynomial coeffs:',ppoly_r_coefs(i0,:) write(0,'(3(a,1pe24.16,x))') 'u_l=',u_l,'u_c=',u_c,'u_r=',u_r write(0,'(a4,10a24)') 'i0','h0(i0)','u0(i0)','left edge','right edge','Polynomial coefficients' do n = 1, n0 - write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefficients(n,:) + write(0,'(i4,1p10e24.16)') n,h0(n),u0(n),ppoly_r_E(n,1),ppoly_r_E(n,2),ppoly_r_coefs(n,:) enddo call MOM_error(FATAL, 'MOM_remapping, check_reconstructions_1d: '// & 'Edge values or polynomial coefficients were inconsistent!') @@ -506,13 +505,13 @@ end subroutine check_reconstructions_1d !> Remaps column of n0 values u0 on grid h0 to grid h1 with n1 cells by calculating !! the n0+n1+1 sub-integrals of the intersection of h0 and h1, and the summing the !! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. -subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h1, method, & +subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(n0) !< Source grid widths (size n0) real, intent(in) :: u0(n0) !< Source cell averages (size n0) real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: n1 !< Number of cells in target grid real, intent(in) :: h1(n1) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use @@ -734,7 +733,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h if (h0_eff(i0)>0.) then xb = dh0_eff / h0_eff(i0) ! This expression yields xa <= xb <= 1.0 xb = min(1., xb) ! This is only needed when the total target column is wider than the source column - u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method, i0, xa, xb) + u_sub(i_sub) = average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) else ! Vanished cell xb = 1. u_sub(i_sub) = u0(i0) @@ -745,7 +744,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h write(0,*) 'xa,xb: ',xa,xb write(0,*) 'Edge values: ',ppoly0_E(i0,:),'mean',u0(i0) write(0,*) 'a_c: ',(u0(i0)-ppoly0_E(i0,1))+(u0(i0)-ppoly0_E(i0,2)) - write(0,*) 'Polynomial coeffs: ',ppoly0_coefficients(i0,:) + write(0,*) 'Polynomial coeffs: ',ppoly0_coefs(i0,:) write(0,*) 'Bounds min=',u0_min(i0),'max=',u0_max(i0) write(0,*) 'Average: ',u_sub(i_sub),'rel to min=',u_sub(i_sub)-u0_min(i0),'rel to max=',u_sub(i_sub)-u0_max(i0) call MOM_error( FATAL, 'MOM_remapping, remap_via_sub_cells: '//& @@ -878,7 +877,7 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, h enddo write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefficients(k,:) + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly0_coefs(k,:) enddo write(0,'(a3,3a24,a3,2a24)') 'k','Sub-cell h','Sub-cell u','Sub-cell hu','i0','xa','xb' xa = 0. @@ -917,11 +916,11 @@ end subroutine remap_via_sub_cells !> Returns the average value of a reconstruction within a single source cell, i0, !! between the non-dimensional positions xa and xb (xa<=xb) with dimensional !! separation dh. -real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method, i0, xa, xb) +real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: u0(:) !< Cell means - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index real, intent(in) :: xa !< Non-dimensional start position within source cell @@ -938,8 +937,8 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = u0(i0) case ( INTEGRATION_PLM ) u_ave = ( & - ppoly0_coefficients(i0,1) & - + ppoly0_coefficients(i0,2) * 0.5 * ( xb + xa ) ) + ppoly0_coefs(i0,1) & + + ppoly0_coefs(i0,2) * 0.5 * ( xb + xa ) ) case ( INTEGRATION_PPM ) mx = 0.5 * ( xa + xb ) a_L = ppoly0_E(i0, 1) @@ -966,21 +965,21 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method xa2pxb2 = xa_2 + xb_2 xapxb = xa + xb u_ave = ( & - ppoly0_coefficients(i0,1) & - + ( ppoly0_coefficients(i0,2) * 0.5 * ( xapxb ) & - + ( ppoly0_coefficients(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & - + ( ppoly0_coefficients(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & - + ppoly0_coefficients(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) + ppoly0_coefs(i0,1) & + + ( ppoly0_coefs(i0,2) * 0.5 * ( xapxb ) & + + ( ppoly0_coefs(i0,3) * r_3 * ( xa2pxb2 + xa*xb ) & + + ( ppoly0_coefs(i0,4) * 0.25* ( xa2pxb2 * xapxb ) & + + ppoly0_coefs(i0,5) * 0.2 * ( ( xb*xb_2 + xa*xa_2 ) * xapxb + xa_2*xb_2 ) ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select else ! dh == 0. select case ( method ) case ( INTEGRATION_PCM ) - u_ave = ppoly0_coefficients(i0,1) + u_ave = ppoly0_coefs(i0,1) case ( INTEGRATION_PLM ) - !u_ave = ppoly0_coefficients(i0,1) & - ! + xa * ppoly0_coefficients(i0,2) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ppoly0_coefs(i0,2) a_L = ppoly0_E(i0, 1) a_R = ppoly0_E(i0, 2) Ya = 1. - xa @@ -990,9 +989,9 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = a_R + Ya * ( a_L - a_R ) endif case ( INTEGRATION_PPM ) - !u_ave = ppoly0_coefficients(i0,1) & - ! + xa * ( ppoly0_coefficients(i0,2) & - ! + xa * ppoly0_coefficients(i0,3) ) + !u_ave = ppoly0_coefs(i0,1) & + ! + xa * ( ppoly0_coefs(i0,2) & + ! + xa * ppoly0_coefs(i0,3) ) a_L = ppoly0_E(i0, 1) a_R = ppoly0_E(i0, 2) u_c = u0(i0) @@ -1004,11 +1003,11 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefficients, method u_ave = a_R + Ya * ( ( a_L - a_R ) + a_c * xa ) endif case ( INTEGRATION_PQM ) - u_ave = ppoly0_coefficients(i0,1) & - + xa * ( ppoly0_coefficients(i0,2) & - + xa * ( ppoly0_coefficients(i0,3) & - + xa * ( ppoly0_coefficients(i0,4) & - + xa * ppoly0_coefficients(i0,5) ) ) ) + u_ave = ppoly0_coefs(i0,1) & + + xa * ( ppoly0_coefs(i0,2) & + + xa * ( ppoly0_coefs(i0,3) & + + xa * ( ppoly0_coefs(i0,4) & + + xa * ppoly0_coefs(i0,5) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1086,13 +1085,13 @@ end subroutine measure_output_bounds !> Remaps column of values u0 on grid h0 to grid h1 by integrating !! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, method, u1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid real, intent(in) :: h0(:) !< Source grid widths (size n0) real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial integer, intent(in) :: n1 !< Number of cells in target grid real, intent(in) :: h1(:) !< Target grid widths (size n1) integer, intent(in) :: method !< Remapping scheme to use @@ -1117,7 +1116,7 @@ subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & xL = xR xR = xL + h1(iTarget) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) end do ! end iTarget loop on target grid cells @@ -1134,19 +1133,20 @@ end subroutine remapByProjection !! where !! F(k) = dx1(k) qAverage !! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & method, u1, h1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) - real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: dx1(:) !< Target grid edge positions (size n1+1) - integer :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) - real, optional, intent(out) :: h1(:) !< Target grid widths (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: n1 !< Number of cells in target grid + real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) + integer, intent(in) :: method !< Remapping scheme to use + real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) + real, dimension(:), & + optional, intent(out) :: h1 !< Target grid widths (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. ! Local variables @@ -1189,7 +1189,7 @@ subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, n1, dx1, & ! hFlux is the positive width of the remapped volume hFlux = abs(dx1(iTarget+1)) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hFlux, uAve, jStart, xStart ) ! uAve is the average value of u, independent of sign of dx1 fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 @@ -1212,22 +1212,23 @@ end subroutine remapByDeltaZ !> Integrate the reconstructed column profile over a single cell -subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, method, & +subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hC, uAve, jStart, xStart, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid sizes (size n0) - real, intent(in) :: u0(:) !< Source cell averages - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefficients(:,:) !< Coefficients of polynomial - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL, xR !< Left/right edges of target cell - real, intent(in) :: hC !< Cell width hC = xR - xL - real, intent(out) :: uAve !< Average value on target cell - integer, intent(inout) :: jStart !< The index of the cell to start searching from + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: method !< Remapping scheme to use + real, intent(in) :: xL !< Left edges of target cell + real, intent(in) :: xR !< Right edges of target cell + real, intent(in) :: hC !< Cell width hC = xR - xL + real, intent(out) :: uAve !< Average value on target cell + integer, intent(inout) :: jStart !< The index of the cell to start searching from !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart + real, intent(inout) :: xStart !< The left edge position of cell jStart !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the + real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. ! Local variables @@ -1302,20 +1303,20 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - uAve = ppoly0_coefficients(jL,1) + uAve = ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ppoly0_coefficients(jL,2) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ppoly0_coefs(jL,2) case ( INTEGRATION_PPM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ( ppoly0_coefficients(jL,2) & - + xi0 * ppoly0_coefficients(jL,3) ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ppoly0_coefs(jL,3) ) case ( INTEGRATION_PQM ) - uAve = ppoly0_coefficients(jL,1) & - + xi0 * ( ppoly0_coefficients(jL,2) & - + xi0 * ( ppoly0_coefficients(jL,3) & - + xi0 * ( ppoly0_coefficients(jL,4) & - + xi0 * ppoly0_coefficients(jL,5) ) ) ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ( ppoly0_coefs(jL,3) & + + xi0 * ( ppoly0_coefs(jL,4) & + + xi0 * ppoly0_coefs(jL,5) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1371,27 +1372,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi select case ( method ) case ( INTEGRATION_PCM ) - q = ( xR - xL ) * ppoly0_coefficients(jL,1) + q = ( xR - xL ) * ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = ( xR - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1423,27 +1424,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - q = q + ( x0jLr - xL ) * ppoly0_coefficients(jL,1) + q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) case ( INTEGRATION_PLM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefficients(jL,1) & - + ( ppoly0_coefficients(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL, 'The selected integration method is invalid' ) end select @@ -1468,27 +1469,27 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, select case ( method ) case ( INTEGRATION_PCM ) - q = q + ( xR - x0jRl ) * ppoly0_coefficients(jR,1) + q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) case ( INTEGRATION_PLM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) case ( INTEGRATION_PPM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ( ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefficients(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) case ( INTEGRATION_PQM ) x0_2 = xi0*xi0 x1_2 = xi1*xi1 x02px12 = x0_2 + x1_2 x0px1 = xi1 + xi0 - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefficients(jR,1) & - + ( ppoly0_coefficients(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefficients(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefficients(jR,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefficients(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) case default call MOM_error( FATAL,'The selected integration method is invalid' ) end select @@ -1498,7 +1499,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefficients, ! The cell average is the integrated value divided by the cell width #ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ if (hAct==0.) then - uAve = ppoly0_coefficients(jL,1) + uAve = ppoly0_coefs(jL,1) else uAve = q / hAct endif @@ -1613,7 +1614,7 @@ logical function remapping_unit_tests(verbose) data h1 /3*1./ ! 3 uniform layers with total depth of 3 data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 type(remapping_CS) :: CS !< Remapping control structure - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefficients + real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs integer :: i real :: err, h_neglect, h_neglect_edge logical :: thisTest, v @@ -1660,17 +1661,17 @@ logical function remapping_unit_tests(verbose) thisTest = .false. allocate(ppoly0_E(n0,2)) allocate(ppoly0_S(n0,2)) - allocate(ppoly0_coefficients(n0,CS%degree+1)) + allocate(ppoly0_coefs(n0,CS%degree+1)) ppoly0_E(:,:) = 0.0 ppoly0_S(:,:) = 0.0 - ppoly0_coefficients(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10 ) - call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) - call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefficients, h_neglect ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) u1(:) = 0. - call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, INTEGRATION_PPM, u1, h_neglect ) do i=1,n1 err=u1(i)-8.*(0.5*real(1+n1)-real(i)) @@ -1681,7 +1682,7 @@ logical function remapping_unit_tests(verbose) thisTest = .false. u1(:) = 0. - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, x1-x0(1:n1+1), & INTEGRATION_PPM, u1, hn1, h_neglect ) if (verbose) write(*,*) 'h1 (by delta)' @@ -1698,7 +1699,7 @@ logical function remapping_unit_tests(verbose) call buildGridFromH(n2, h2, x2) dx2(1:n0+1) = x2(1:n0+1) - x0 dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, dx2, & INTEGRATION_PPM, u2, hn2, h_neglect ) if (verbose) write(*,*) 'h2' @@ -1715,7 +1716,7 @@ logical function remapping_unit_tests(verbose) if (verbose) write(*,*) 'Via sub-cells' thisTest = .false. - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n2, h2, INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(n2,h2,x2,u2) @@ -1726,11 +1727,11 @@ logical function remapping_unit_tests(verbose) if (thisTest) write(*,*) 'remapping_unit_tests: Failed remap_via_sub_cells() 2' remapping_unit_tests = remapping_unit_tests .or. thisTest - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 6, (/.125,.125,.125,.125,.125,.125/), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(6,h2,x2,u2) - call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefficients, & + call remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, & 3, (/2.25,1.5,1./), INTEGRATION_PPM, .false., u2, err ) if (verbose) call dumpGrid(3,h2,x2,u2) @@ -1738,63 +1739,63 @@ logical function remapping_unit_tests(verbose) write(*,*) '===== MOM_remapping: new remapping_unit_tests ==================' - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) - allocate(ppoly0_coefficients(5,6)) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + allocate(ppoly0_coefs(5,6)) allocate(ppoly0_E(5,2)) allocate(ppoly0_S(5,2)) call PCM_reconstruction(3, (/1.,2.,4./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:) ) + ppoly0_coefs(1:3,:) ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,4./), 'PCM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,2.,4./), 'PCM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,4./), 'PCM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,4./), 'PCM: P0') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,3.,5./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,5./), 'Unlim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,4.,5./), 'Unlim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,5./), 'Unlim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,5./), 'Unlim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Unlim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Unlim PLM: P1') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,2.,7./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,1.,7./), 'Left lim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,3.,7./), 'Left lim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,1.,7./), 'Left lim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,1.,7./), 'Left lim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Left lim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Left lim PLM: P1') call PLM_reconstruction(3, (/1.,1.,1./), (/1.,6.,7./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,5.,7./), 'Right lim PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,7.,7./), 'Right lim PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,5.,7./), 'Right lim PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,5.,7./), 'Right lim PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,2.,0./), 'Right lim PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,2.,0./), 'Right lim PLM: P1') call PLM_reconstruction(3, (/1.,2.,3./), (/1.,4.,9./), ppoly0_E(1:3,:), & - ppoly0_coefficients(1:3,:), h_neglect ) + ppoly0_coefs(1:3,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,1), (/1.,2.,9./), 'Non-uniform line PLM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 3, ppoly0_E(:,2), (/1.,6.,9./), 'Non-uniform line PLM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') + test_answer(v, 3, ppoly0_coefs(:,1), (/1.,2.,9./), 'Non-uniform line PLM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 3, ppoly0_coefficients(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') + test_answer(v, 3, ppoly0_coefs(:,2), (/0.,4.,0./), 'Non-uniform line PLM: P1') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E, & h_neglect=1e-10 ) @@ -1804,13 +1805,13 @@ logical function remapping_unit_tests(verbose) ppoly0_E(:,1) = (/0.,2.,4.,6.,8./) ppoly0_E(:,2) = (/2.,4.,6.,8.,10./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/1.,3.,5.,7.,9./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/1.,2.,4.,6.,9./), 'Line PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,2.,2.,2.,0./), 'Line PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,0.,0.,0.,0./), 'Line PPM: P2') call edge_values_explicit_h4( 5, (/1.,1.,1.,1.,1./), (/1.,1.,7.,19.,37./), ppoly0_E, & h_neglect=1e-10 ) @@ -1820,46 +1821,46 @@ logical function remapping_unit_tests(verbose) ppoly0_E(:,1) = (/0.,0.,3.,12.,27./) ppoly0_E(:,2) = (/0.,3.,12.,27.,48./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,1.,7.,19.,37./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,2), (/0.,3.,12.,27.,37./), 'Parabola PPM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,0.,3.,12.,37./), 'Parabola PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,0.,6.,12.,0./), 'Parabola PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,3.,3.,3.,0./), 'Parabola PPM: P2') ppoly0_E(:,1) = (/0.,0.,6.,10.,15./) ppoly0_E(:,2) = (/0.,6.,12.,17.,15./) call PPM_reconstruction(5, (/1.,1.,1.,1.,1./), (/0.,5.,7.,16.,15./), ppoly0_E(1:5,:), & - ppoly0_coefficients(1:5,:), h_neglect ) + ppoly0_coefs(1:5,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: left edges') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 5, ppoly0_E(:,2), (/0.,6.,9.,16.,15./), 'Limits PPM: right edges') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') + test_answer(v, 5, ppoly0_coefs(:,1), (/0.,3.,6.,16.,15./), 'Limits PPM: P0') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') + test_answer(v, 5, ppoly0_coefs(:,2), (/0.,6.,0.,0.,0./), 'Limits PPM: P1') remapping_unit_tests = remapping_unit_tests .or. & - test_answer(v, 5, ppoly0_coefficients(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') + test_answer(v, 5, ppoly0_coefs(:,3), (/0.,-3.,3.,0.,0./), 'Limits PPM: P2') call PLM_reconstruction(4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefficients(1:4,:), h_neglect ) + ppoly0_coefs(1:4,:), h_neglect ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 4, ppoly0_E(1:4,1), (/5.,5.,3.,1./), 'PPM: left edges h=0110') remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 4, ppoly0_E(1:4,2), (/5.,3.,1.,1./), 'PPM: right edges h=0110') call remap_via_sub_cells( 4, (/0.,1.,1.,0./), (/5.,4.,2.,1./), ppoly0_E(1:4,:), & - ppoly0_coefficients(1:4,:), & + ppoly0_coefs(1:4,:), & 2, (/1.,1./), INTEGRATION_PLM, .false., u2, err ) remapping_unit_tests = remapping_unit_tests .or. & test_answer(v, 2, u2, (/4.,2./), 'PLM: remapped h=0110->h=11') - deallocate(ppoly0_E, ppoly0_S, ppoly0_coefficients) + deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) if (.not. remapping_unit_tests) write(*,*) 'Pass' diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index a7a7635800..8590a7297f 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -39,9 +39,8 @@ module P1M_functions !------------------------------------------------------------------------------ -! p1m interpolation -!------------------------------------------------------------------------------ -subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) +!> Linearly interpolate between edge values +subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) ! ------------------------------------------------------------------------------ ! Linearly interpolate between edge values. ! The resulting piecewise interpolant is stored in 'ppoly'. @@ -62,7 +61,7 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) real, dimension(:), intent(in) :: u !< cell average properties (size N) real, dimension(:,:), intent(inout) :: ppoly_E !< Potentially modified edge values, !! with the same units as u. - real, dimension(:,:), intent(inout) :: ppoly_coefficients !< Potentially modified + real, dimension(:,:), intent(inout) :: ppoly_coef !< Potentially modified !! piecewise polynomial coefficients, mainly !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width @@ -85,8 +84,8 @@ subroutine P1M_interpolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) u0_l = ppoly_E(k,1) u0_r = ppoly_E(k,2) - ppoly_coefficients(k,1) = u0_l - ppoly_coefficients(k,2) = u0_r - u0_l + ppoly_coef(k,1) = u0_l + ppoly_coef(k,2) = u0_r - u0_l end do ! end loop on interior cells @@ -94,9 +93,8 @@ end subroutine P1M_interpolation !------------------------------------------------------------------------------ -! p1m boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) +!> Interpolation by linear polynomials within boundary cells +subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) !------------------------------------------------------------------------------ ! Interpolation by linear polynomials within boundary cells. ! The left and right edge values in the left and right boundary cells, @@ -106,18 +104,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. ! Local variables real :: u0, u1 ! cell averages @@ -145,20 +145,20 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! by using the edge value in the neighboring cell. u0_r = u0 + 0.5 * slope - if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) .LT. 0.0 ) then + if ( (u1 - u0) * (ppoly_E(2,1) - u0_r) < 0.0 ) then slope = 2.0 * ( ppoly_E(2,1) - u0 ) end if ! Using the limited slope, the left edge value is reevaluated and ! the interpolant coefficients recomputed - if ( h0 .NE. 0.0 ) then + if ( h0 /= 0.0 ) then ppoly_E(1,1) = u0 - 0.5 * slope else ppoly_E(1,1) = u0 end if - ppoly_coefficients(1,1) = ppoly_E(1,1) - ppoly_coefficients(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = ppoly_E(1,1) + ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -173,18 +173,18 @@ subroutine P1M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) u0_l = u1 - 0.5 * slope - if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) .LT. 0.0 ) then + if ( (u1 - u0) * (u0_l - ppoly_E(N-1,2)) < 0.0 ) then slope = 2.0 * ( u1 - ppoly_E(N-1,2) ) end if - if ( h1 .NE. 0.0 ) then + if ( h1 /= 0.0 ) then ppoly_E(N,2) = u1 + 0.5 * slope else ppoly_E(N,2) = u1 end if - ppoly_coefficients(N,1) = ppoly_E(N,1) - ppoly_coefficients(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = ppoly_E(N,1) + ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) end subroutine P1M_boundary_extrapolation diff --git a/src/ALE/P3M_functions.F90 b/src/ALE/P3M_functions.F90 index ecc7136ead..acc3e064ce 100644 --- a/src/ALE/P3M_functions.F90 +++ b/src/ALE/P3M_functions.F90 @@ -28,9 +28,9 @@ module P3M_functions contains !------------------------------------------------------------------------------ -! p3m interpolation -! ----------------------------------------------------------------------------- -subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & +!> Set up a piecewise cubic cubic interpolation from cell averages and estimated +!! edge slopes and values +subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect ) !------------------------------------------------------------------------------ ! Cubic interpolation between edges. @@ -43,12 +43,15 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. @@ -59,15 +62,15 @@ subroutine P3M_interpolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & ! 'P3M_interpolation' first but we do that to provide an homogeneous ! interface. - call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) + call P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) end subroutine P3M_interpolation !------------------------------------------------------------------------------ -! p3m limiter -! ----------------------------------------------------------------------------- -subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) +!> Adust a piecewise cubic reconstruction with a limiter that adjusts the edge +!! values and slopes +subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! The p3m limiter operates as follows: ! @@ -82,12 +85,14 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions !! in the same units as h. @@ -133,7 +138,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect u_c = u(k) h_c = h(k) - if ( k .EQ. 1 ) then + if ( k == 1 ) then h_l = h(k) u_l = u(k) else @@ -141,7 +146,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect u_l = u(k-1) end if - if ( k .EQ. N ) then + if ( k == N ) then h_r = h(k) u_r = u(k) else @@ -154,7 +159,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 @@ -173,24 +178,24 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ! The edge slopes are limited from above by the respective ! one-sided slopes - if ( abs(u1_l) .GT. abs(sigma_l) ) then + if ( abs(u1_l) > abs(sigma_l) ) then u1_l = sigma_l end if - if ( abs(u1_r) .GT. abs(sigma_r) ) then + if ( abs(u1_r) > abs(sigma_r) ) then u1_r = sigma_r end if ! Build cubic interpolant (compute the coefficients) - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) ! Check whether cubic is monotonic - monotonic = is_cubic_monotonic( ppoly_coefficients, k ) + monotonic = is_cubic_monotonic( ppoly_coef, k ) ! If cubic is not monotonic, monotonize it by modifiying the ! edge slopes, store the new edge slopes and recompute the ! cubic coefficients - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h_c, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) end if @@ -199,7 +204,7 @@ subroutine P3M_limiter( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ppoly_S(k,2) = u1_r ! Recompute coefficients of cubic - call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) end do ! loop on cells @@ -207,9 +212,9 @@ end subroutine P3M_limiter !------------------------------------------------------------------------------ -! p3m boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, & +!> calculate the edge values and slopes at boundary cells as part of building a +!! piecewise peicewise cubic sub-grid scale profiles +subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coef, & h_neglect, h_neglect_edge ) !------------------------------------------------------------------------------ ! The following explanations apply to the left boundary cell. The same @@ -225,12 +230,15 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h. @@ -263,12 +271,12 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b / h1 ! derivative evaluated at xi = 0.0, expressed w.r.t. x ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) / ( h0 + hNeglect ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope end if @@ -285,7 +293,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Check whether the edge values are monotonic. For example, if the left edge ! value is larger than the right edge value while the slope is positive, the ! edge values are inconsistent and we need to modify the left edge value - if ( (u0_r-u0_l) * slope .LT. 0.0 ) then + if ( (u0_r-u0_l) * slope < 0.0 ) then u0_l = u0_r u1_l = 0.0 u1_r = 0.0 @@ -298,16 +306,16 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ppoly_S(i0,2) = u1_r ! Store edge values and slope, build cubic and check monotonicity - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coefficients ) - monotonic = is_cubic_monotonic( ppoly_coefficients, i0 ) + call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i0 ) - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h0, u0_l, u0_r, 0.0, slope, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization ppoly_S(i0,1) = u1_l ppoly_S(i0,2) = u1_r - call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, i0, ppoly_E, ppoly_S, ppoly_coef ) end if @@ -321,14 +329,14 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) u1_l = (b + 2*c + 3*d) / ( h0 + hNeglect ) ! derivative evaluated at xi = 1.0 ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) / ( h1 + hNeglect ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope end if @@ -345,7 +353,7 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ! Check whether the edge values are monotonic. For example, if the right edge ! value is smaller than the left edge value while the slope is positive, the ! edge values are inconsistent and we need to modify the right edge value - if ( (u0_r-u0_l) * slope .LT. 0.0 ) then + if ( (u0_r-u0_l) * slope < 0.0 ) then u0_r = u0_l u1_l = 0.0 u1_r = 0.0 @@ -357,16 +365,16 @@ subroutine P3M_boundary_extrapolation( N, h, u, ppoly_E, ppoly_S, ppoly_coeffici ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coefficients ) - monotonic = is_cubic_monotonic( ppoly_coefficients, i1 ) + call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) + monotonic = is_cubic_monotonic( ppoly_coef, i1 ) - if ( monotonic .EQ. 0 ) then + if ( monotonic == 0 ) then call monotonize_cubic( h1, u0_l, u0_r, slope, 0.0, slope, u1_l, u1_r ) ! Rebuild cubic after monotonization ppoly_S(i1,1) = u1_l ppoly_S(i1,2) = u1_r - call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coefficients ) + call build_cubic_interpolant( h, i1, ppoly_E, ppoly_S, ppoly_coef ) end if @@ -374,9 +382,8 @@ end subroutine P3M_boundary_extrapolation !------------------------------------------------------------------------------ -! Build cubic interpolant in cell k -! ----------------------------------------------------------------------------- -subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) +!> Build cubic interpolant in cell k +subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coef ) !------------------------------------------------------------------------------ ! Given edge values and edge slopes, compute coefficients of cubic in cell k. ! @@ -385,11 +392,14 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) !------------------------------------------------------------------------------ ! Arguments - real, dimension(:), intent(in) :: h ! cell widths (size N) - integer, intent(in) :: k - real, dimension(:,:), intent(in) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + real, dimension(:), intent(in) :: h !< cell widths (size N) + integer, intent(in) :: k !< The index of the cell to work on + real, dimension(:,:), intent(in) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(in) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. ! Local variables real :: u0_l, u0_r ! edge values @@ -410,18 +420,17 @@ subroutine build_cubic_interpolant( h, k, ppoly_E, ppoly_S, ppoly_coefficients ) a2 = 3.0 * ( u0_r - u0_l ) - u1_r - 2.0 * u1_l a3 = u1_r + u1_l + 2.0 * ( u0_l - u0_r ) - ppoly_coefficients(k,1) = a0 - ppoly_coefficients(k,2) = a1 - ppoly_coefficients(k,3) = a2 - ppoly_coefficients(k,4) = a3 + ppoly_coef(k,1) = a0 + ppoly_coef(k,2) = a1 + ppoly_coef(k,3) = a2 + ppoly_coef(k,4) = a3 end subroutine build_cubic_interpolant !------------------------------------------------------------------------------ -! Check whether cubic is monotonic -! ----------------------------------------------------------------------------- -integer function is_cubic_monotonic( ppoly_coefficients, k ) +!> Check whether the cubic reconstruction in cell k is monotonic +integer function is_cubic_monotonic( ppoly_coef, k ) !------------------------------------------------------------------------------ ! This function checks whether the cubic curve in cell k is monotonic. ! If so, returns 1. Otherwise, returns 0. @@ -432,8 +441,8 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) !------------------------------------------------------------------------------ ! Arguments - real, dimension(:,:), intent(in) :: ppoly_coefficients - integer, intent(in) :: k + real, dimension(:,:), intent(in) :: ppoly_coef !< Coefficients of cubic polynomial + integer, intent(in) :: k !< The index of the cell to work on ! Local variables integer :: monotonic ! boolean indicating if monotonic or not @@ -447,10 +456,10 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) ! to be equal to 0 or 1, respectively eps = 1e-14 - a0 = ppoly_coefficients(k,1) - a1 = ppoly_coefficients(k,2) - a2 = ppoly_coefficients(k,3) - a3 = ppoly_coefficients(k,4) + a0 = ppoly_coef(k,1) + a1 = ppoly_coef(k,2) + a2 = ppoly_coef(k,3) + a3 = ppoly_coef(k,4) a = a1 b = 2.0 * a2 @@ -461,19 +470,19 @@ integer function is_cubic_monotonic( ppoly_coefficients, k ) rho = b*b - 4.0*a*c - if ( rho .GE. 0.0 ) then - if ( abs(c) .GT. 1e-15 ) then + if ( rho >= 0.0 ) then + if ( abs(c) > 1e-15 ) then xi_0 = 0.5 * ( -b - sqrt( rho ) ) / c xi_1 = 0.5 * ( -b + sqrt( rho ) ) / c - else if ( abs(b) .GT. 1e-15 ) then + else if ( abs(b) > 1e-15 ) then xi_0 = - a / b xi_1 = - a / b end if ! If one of the roots of the first derivative lies in (0,1), ! the cubic is not monotonic. - if ( ( (xi_0 .GT. eps) .AND. (xi_0 .LT. 1.0-eps) ) .OR. & - ( (xi_1 .GT. eps) .AND. (xi_1 .LT. 1.0-eps) ) ) then + if ( ( (xi_0 > eps) .AND. (xi_0 < 1.0-eps) ) .OR. & + ( (xi_1 > eps) .AND. (xi_1 < 1.0-eps) ) ) then monotonic = 0 else monotonic = 1 @@ -490,8 +499,7 @@ end function is_cubic_monotonic !------------------------------------------------------------------------------ -! Monotonize cubic curve -! ----------------------------------------------------------------------------- +!> Monotonize a cubic curve by modifying the edge slopes. subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ) !------------------------------------------------------------------------------ ! This routine takes care of monotonizing a cubic on [0,1] by modifying the @@ -522,11 +530,14 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r !------------------------------------------------------------------------------ ! Arguments - real, intent(in) :: h ! cell width - real, intent(in) :: u0_l, u0_r ! edge values - real, intent(in) :: sigma_l, sigma_r ! left and right 2nd-order slopes - real, intent(in) :: slope ! limited PLM slope - real, intent(inout) :: u1_l, u1_r ! edge slopes + real, intent(in) :: h !< cell width + real, intent(in) :: u0_l !< left edge value + real, intent(in) :: u0_r !< right edge value + real, intent(in) :: sigma_l !< left 2nd-order slopes + real, intent(in) :: sigma_r !< right 2nd-order slopes + real, intent(in) :: slope !< limited PLM slope + real, intent(inout) :: u1_l !< left edge slopes + real, intent(inout) :: u1_r !< right edge slopes ! Local variables integer :: found_ip @@ -547,11 +558,11 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! If the edge slopes are inconsistent w.r.t. the limited PLM slope, ! set them to zero - if ( u1_l*slope .LE. 0.0 ) then + if ( u1_l*slope <= 0.0 ) then u1_l = 0.0 end if - if ( u1_r*slope .LE. 0.0 ) then + if ( u1_r*slope <= 0.0 ) then u1_r = 0.0 end if @@ -564,12 +575,12 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! There is a possible root (and inflexion point) only if a3 is nonzero. ! When a3 is zero, the second derivative of the cubic is constant (the ! cubic degenerates into a parabola) and no inflexion point exists. - if ( a3 .NE. 0.0 ) then + if ( a3 /= 0.0 ) then ! Location of inflexion point xi_ip = - a2 / (3.0 * a3) ! If the inflexion point lies in [0,1], change boolean value - if ( (xi_ip .GE. 0.0) .AND. (xi_ip .LE. 1.0) ) then + if ( (xi_ip >= 0.0) .AND. (xi_ip <= 1.0) ) then found_ip = 1 end if end if @@ -579,12 +590,12 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! decide on which side we want to collapse the inflexion point. ! If the inflexion point lies on one of the edges, the cubic is ! guaranteed to be monotonic - if ( found_ip .EQ. 1 ) then + if ( found_ip == 1 ) then slope_ip = a1 + 2.0*a2*xi_ip + 3.0*a3*xi_ip*xi_ip ! Check whether slope is consistent - if ( slope_ip*slope .LT. 0.0 ) then - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( slope_ip*slope < 0.0 ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 @@ -597,22 +608,22 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r ! 'inflexion_l' and 'inflexion_r' are set to 0 and nothing is to be done. ! Move inflexion point on the left - if ( inflexion_l .EQ. 1 ) then + if ( inflexion_l == 1 ) then u1_l_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_r u1_r_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_l - if ( (u1_l_tmp*slope .LT. 0.0) .AND. (u1_r_tmp*slope .LT. 0.0) ) then + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then u1_l = 0.0 u1_r = 3.0 * (u0_r - u0_l) / h - else if (u1_l_tmp*slope .LT. 0.0) then + else if (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 1.5*(u0_r - u0_l)/h - 0.5*u1_r - else if (u1_r_tmp*slope .LT. 0.0) then + else if (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 3.0*(u0_r - u0_l)/h - 2.0*u1_l @@ -627,22 +638,22 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r end if ! end treating case with inflexion point on the left ! Move inflexion point on the right - if ( inflexion_r .EQ. 1 ) then + if ( inflexion_r == 1 ) then u1_l_tmp = 3.0*(u0_r-u0_l)/h - 2.0*u1_r u1_r_tmp = 1.5*(u0_r-u0_l)/h - 0.5*u1_l - if ( (u1_l_tmp*slope .LT. 0.0) .AND. (u1_r_tmp*slope .LT. 0.0) ) then + if ( (u1_l_tmp*slope < 0.0) .AND. (u1_r_tmp*slope < 0.0) ) then u1_l = 3.0 * (u0_r - u0_l) / h u1_r = 0.0 - else if (u1_l_tmp*slope .LT. 0.0) then + else if (u1_l_tmp*slope < 0.0) then u1_r = u1_r_tmp u1_l = 3.0*(u0_r - u0_l)/h - 2.0*u1_r - else if (u1_r_tmp*slope .LT. 0.0) then + else if (u1_r_tmp*slope < 0.0) then u1_l = u1_l_tmp u1_r = 1.5*(u0_r - u0_l)/h - 0.5*u1_l @@ -656,11 +667,11 @@ subroutine monotonize_cubic( h, u0_l, u0_r, sigma_l, sigma_r, slope, u1_l, u1_r end if ! end treating case with inflexion point on the right - if ( abs(u1_l*h) .LT. eps ) then + if ( abs(u1_l*h) < eps ) then u1_l = 0.0 end if - if ( abs(u1_r*h) .LT. eps ) then + if ( abs(u1_r*h) < eps ) then u1_r = 0.0 end if diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index b09f6e080e..bcb963faa6 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -19,9 +19,10 @@ module PCM_functions contains !------------------------------------------------------------------------------ -! pcm_reconstruction -!------------------------------------------------------------------------------ -subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coefficients ) +!> Reconstruction by constant polynomials within each cell. There is nothing to +!! do but this routine is provided to ensure a homogeneous interface +!! throughout the regridding toolbox. +subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coef ) !------------------------------------------------------------------------------ ! Reconstruction by constant polynomials within each cell. There is nothing to ! do but this routine is provided to ensure a homogeneous interface @@ -31,24 +32,26 @@ subroutine PCM_reconstruction( N, u, ppoly_E, ppoly_coefficients ) ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the dimension of 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: u ! cell averages - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, + !! with the same units as u. ! Local variables integer :: k ! The coefficients of the piecewise constant polynomial are simply ! the cell averages. - ppoly_coefficients(:,1) = u(:) + ppoly_coef(:,1) = u(:) ! The edge values are equal to the cell average do k = 1,N diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index 83eea1518b..73f9206c21 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -21,9 +21,8 @@ module PLM_functions contains !------------------------------------------------------------------------------ -! PLM_reconstruction -! ----------------------------------------------------------------------------- -subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) +!> Reconstruction by linear polynomials within each cell +subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within each cell. ! @@ -31,21 +30,23 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -171,8 +172,8 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ! Store and return edge values and polynomial coefficients. ppoly_E(1,1) = u(1) ppoly_E(1,2) = u(1) - ppoly_coefficients(1,1) = u(1) - ppoly_coefficients(1,2) = 0. + ppoly_coef(1,1) = u(1) + ppoly_coef(1,2) = 0. do k = 2, N-1 slope = sign( mslp(k), slp(k) ) u_l = u(k) - 0.5 * slope ! Left edge value of cell k @@ -194,28 +195,27 @@ subroutine PLM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) ppoly_E(k,1) = u_l ppoly_E(k,2) = u_r - ppoly_coefficients(k,1) = u_l - ppoly_coefficients(k,2) = ( u_r - u_l ) + ppoly_coef(k,1) = u_l + ppoly_coef(k,2) = ( u_r - u_l ) ! Check to see if this evaluation of the polynomial at x=1 would be ! monotonic w.r.t. the next cell's edge value. If not, scale back! - edge = ppoly_coefficients(k,2) + ppoly_coefficients(k,1) + edge = ppoly_coef(k,2) + ppoly_coef(k,1) e_r = u(k+1) - 0.5 * sign( mslp(k+1), slp(k+1) ) if ( (edge-u(k))*(e_r-edge)<0.) then - ppoly_coefficients(k,2) = ppoly_coefficients(k,2) * almost_one + ppoly_coef(k,2) = ppoly_coef(k,2) * almost_one endif enddo ppoly_E(N,1) = u(N) ppoly_E(N,2) = u(N) - ppoly_coefficients(N,1) = u(N) - ppoly_coefficients(N,2) = 0. + ppoly_coef(N,1) = u(N) + ppoly_coef(N,2) = 0. end subroutine PLM_reconstruction !------------------------------------------------------------------------------ -! plm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect ) +!> Reconstruction by linear polynomials within boundary cells +subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by linear polynomials within boundary cells. ! The left and right edge values in the left and right boundary cells, @@ -227,21 +227,23 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables real :: u0, u1 ! cell averages @@ -270,8 +272,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ppoly_E(1,1) = u0 - 0.5 * slope ppoly_E(1,2) = u0 + 0.5 * slope - ppoly_coefficients(1,1) = ppoly_E(1,1) - ppoly_coefficients(1,2) = ppoly_E(1,2) - ppoly_E(1,1) + ppoly_coef(1,1) = ppoly_E(1,1) + ppoly_coef(1,2) = ppoly_E(1,2) - ppoly_E(1,1) ! ------------------------------------------ ! Right edge value in the left boundary cell @@ -292,8 +294,8 @@ subroutine PLM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ppoly_E(N,1) = u1 - 0.5 * slope ppoly_E(N,2) = u1 + 0.5 * slope - ppoly_coefficients(N,1) = ppoly_E(N,1) - ppoly_coefficients(N,2) = ppoly_E(N,2) - ppoly_E(N,1) + ppoly_coef(N,1) = ppoly_E(N,1) + ppoly_coef(N,2) = ppoly_E(N,2) - ppoly_E(N,1) end subroutine PLM_boundary_extrapolation diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 4dd6699722..d0eb8325ad 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -25,12 +25,14 @@ module PPM_functions contains !> Builds quadratic polynomials coefficients from cell mean and edge values. -subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) +subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coef, h_neglect) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths real, dimension(N), intent(in) :: u !< Cell averages - real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values - real, dimension(N,3), intent(inout) :: ppoly_coefficients !< Polynomial coefficients + real, dimension(N,2), intent(inout) :: ppoly_E !< Edge values, + !! with the same units as u. + real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly + !! with the same units as u. real, optional, intent(in) :: h_neglect !< A negligibly small width !! in the same units as h. ! Local variables @@ -47,9 +49,9 @@ subroutine PPM_reconstruction( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) edge_r = ppoly_E(k,2) ! Store polynomial coefficients - ppoly_coefficients(k,1) = edge_l - ppoly_coefficients(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) - ppoly_coefficients(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) + ppoly_coef(k,1) = edge_l + ppoly_coef(k,2) = 4.0 * ( u(k) - edge_l ) + 2.0 * ( u(k) - edge_r ) + ppoly_coef(k,3) = 3.0 * ( ( edge_r - u(k) ) + ( edge_l - u(k) ) ) enddo @@ -127,9 +129,8 @@ end subroutine PPM_limiter_standard !------------------------------------------------------------------------------ -! ppm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_neglect) +!> Reconstruction by parabolas within boundary cells +subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef, h_neglect) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -148,21 +149,23 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! h: thicknesses of grid cells ! u: cell averages to use in constructing piecewise polynomials ! ppoly_E : edge values of piecewise polynomials -! ppoly_coefficients : coefficients of piecewise polynomials +! ppoly_coef : coefficients of piecewise polynomials ! ! It is assumed that the size of the array 'u' is equal to the number of cells ! defining 'grid' and 'ppoly'. No consistency check is performed here. !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E - real, dimension(:,:), intent(inout) :: ppoly_coefficients - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< edge values of piecewise polynomials, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: i0, i1 @@ -187,13 +190,13 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b *((h0+hNeglect)/(h1+hNeglect)) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope end if @@ -210,11 +213,11 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r end if - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l end if @@ -225,9 +228,9 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n b = 6.0 * u0 - 4.0 * u0_l - 2.0 * u0_r c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c ! ----- Right boundary ----- i0 = N-1 @@ -239,14 +242,14 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) u1_l = (b + 2*c) ! derivative evaluated at xi = 1.0 u1_l = u1_l * ((h1+hNeglect)/(h0+hNeglect)) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope end if @@ -263,11 +266,11 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r end if - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l end if @@ -278,9 +281,9 @@ subroutine PPM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients, h_n b = 6.0 * u1 - 4.0 * u0_l - 2.0 * u0_r c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c end subroutine PPM_boundary_extrapolation diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index 707cd9f40f..6c89c7ac10 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -22,9 +22,8 @@ module PQM_functions contains !------------------------------------------------------------------------------ -! PQM_reconstruction -! ----------------------------------------------------------------------------- -subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) +!> PQM_reconstruction does reconstruction by quartic polynomials within each cell. +subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by quartic polynomials within each cell. ! @@ -37,15 +36,18 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_ !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h ! Local variables integer :: k ! loop index @@ -75,11 +77,11 @@ subroutine PQM_reconstruction( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_ e = 30.0 * u(k) + 2.5*h_c*(u1_r - u1_l) - 15.0*(u0_l + u0_r) ! Store coefficients - ppoly_coefficients(k,1) = a - ppoly_coefficients(k,2) = b - ppoly_coefficients(k,3) = c - ppoly_coefficients(k,4) = d - ppoly_coefficients(k,5) = e + ppoly_coef(k,1) = a + ppoly_coef(k,2) = b + ppoly_coef(k,3) = c + ppoly_coef(k,4) = d + ppoly_coef(k,5) = e end do ! end loop on cells @@ -87,8 +89,7 @@ end subroutine PQM_reconstruction !------------------------------------------------------------------------------ -! Limit pqm -! ----------------------------------------------------------------------------- +!> Limit the piecewise quartic method reconstruction subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) !------------------------------------------------------------------------------ ! Standard PQM limiter (White & Adcroft, JCP 2008). @@ -141,7 +142,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! Loop on interior cells to apply the PQM limiter do k = 2,N-1 - !if ( h(k) .lt. 1.0 ) cycle + !if ( h(k) < 1.0 ) cycle inflexion_l = 0 inflexion_r = 0 @@ -166,7 +167,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 @@ -174,11 +175,11 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! If one of the slopes has the wrong sign compared with the ! limited PLM slope, it is set equal to the limited PLM slope - if ( u1_l*slope .le. 0.0 ) u1_l = slope - if ( u1_r*slope .le. 0.0 ) u1_r = slope + if ( u1_l*slope <= 0.0 ) u1_l = slope + if ( u1_r*slope <= 0.0 ) u1_r = slope ! Local extremum --> flatten - if ( (u0_r - u_c) * (u_c - u0_l) .le. 0.0) then + if ( (u0_r - u_c) * (u_c - u0_l) <= 0.0) then u0_l = u_c u0_r = u_c u1_l = 0.0 @@ -191,7 +192,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! monotonic, edge slopes are consistent and the cell is not an extremum. ! We now need to check and encorce the monotonicity of the quartic within ! the cell - if ( (inflexion_l .EQ. 0) .AND. (inflexion_r .EQ. 0) ) then + if ( (inflexion_l == 0) .AND. (inflexion_r == 0) ) then a = u0_l b = h_c * u1_l @@ -208,7 +209,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) rho = alpha2 * alpha2 - 4.0 * alpha1 * alpha3 ! Check whether inflexion points exist - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) @@ -216,18 +217,18 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 ! Check whether both inflexion points lie in [0,1] - if ( (x1 .GE. 0.0) .AND. (x1 .LE. 1.0) .AND. & - (x2 .GE. 0.0) .AND. (x2 .LE. 1.0) ) then + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) .AND. & + (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b ! Check whether one of the gradients is inconsistent - if ( (gradient1 * slope .LT. 0.0) .OR. & - (gradient2 * slope .LT. 0.0) ) then + if ( (gradient1 * slope < 0.0) .OR. & + (gradient2 * slope < 0.0) ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 @@ -236,15 +237,15 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! If both x1 and x2 do not lie in [0,1], check whether ! only x1 lies in [0,1] - else if ( (x1 .GE. 0.0) .AND. (x1 .LE. 1.0) ) then + else if ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b ! Check whether the gradient is inconsistent - if ( gradient1 * slope .LT. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 @@ -252,15 +253,15 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) end if ! If x1 does not lie in [0,1], check whether x2 lies in [0,1] - else if ( (x2 .GE. 0.0) .AND. (x2 .LE. 1.0) ) then + else if ( (x2 >= 0.0) .AND. (x2 <= 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b ! Check whether the gradient is inconsistent - if ( gradient2 * slope .LT. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 @@ -273,18 +274,18 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! If alpha1 is zero, the second derivative of the quartic reduces ! to a straight line - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .AND. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .AND. (x1 <= 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b ! Check whether the gradient is inconsistent - if ( gradient1 * slope .LT. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then ! Decide where to collapse inflexion points ! (depends on one-sided slopes) - if ( abs(sigma_l) .LT. abs(sigma_r) ) then + if ( abs(sigma_l) < abs(sigma_r) ) then inflexion_l = 1 else inflexion_r = 1 @@ -298,7 +299,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) end if ! end checking whether to shift inflexion points ! At this point, we know onto which edge to shift inflexion points - if ( inflexion_l .EQ. 1 ) then + if ( inflexion_l == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge @@ -309,13 +310,13 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the left edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = 5.0 * u_c - 4.0 * u0_l u1_r = 20.0 * (u_c - u0_l) / ( h_c + hNeglect ) - else if ( u1_r * slope .LT. 0.0 ) then + else if ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*u_c - 3.0*u0_r) / 2.0 @@ -323,7 +324,7 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) end if - else if ( inflexion_r .EQ. 1 ) then + else if ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -334,13 +335,13 @@ subroutine PQM_limiter( N, h, u, ppoly_E, ppoly_S, h_neglect ) ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the right edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = ( 5.0 * u_c - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (u_c - u0_l) / (3.0 * h_c + hNeglect) - else if ( u1_r * slope .LT. 0.0 ) then + else if ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * u_c - 4.0 * u0_r @@ -369,9 +370,8 @@ end subroutine PQM_limiter !------------------------------------------------------------------------------ -! pqm boundary extrapolation -! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) +!> piecewise quartic method boundary extrapolation +subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coef ) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -395,11 +395,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. ! Local variables integer :: i0, i1 @@ -421,13 +423,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! Compute the left edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i1,2) + b = ppoly_coef(i1,2) u1_r = b *(h0/h1) ! derivative evaluated at xi = 0.0, ! expressed w.r.t. xi (local coord. system) ! Limit the right slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_r) .GT. abs(slope) ) then + if ( abs(u1_r) > abs(slope) ) then u1_r = slope end if @@ -444,11 +446,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) exp1 = (u0_r - u0_l) * (u0 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u0 - 2.0 * u0_r end if - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u0 - 2.0 * u0_l end if @@ -460,11 +462,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) c = 3.0 * ( u0_r + u0_l - 2.0 * u0 ) ! The quartic is reduced to a parabola in the boundary cell - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c - ppoly_coefficients(i0,4) = 0.0 - ppoly_coefficients(i0,5) = 0.0 + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = 0.0 + ppoly_coef(i0,5) = 0.0 ! ----- Right boundary ----- i0 = N-1 @@ -476,16 +478,16 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) ! Compute the right edge slope in neighboring cell and express it in ! the global coordinate system - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) - e = ppoly_coefficients(i0,5) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) u1_l = (b + 2*c + 3*d + 4*e) ! derivative evaluated at xi = 1.0 u1_l = u1_l * (h1/h0) ! Limit the left slope by the PLM limited slope slope = 2.0 * ( u1 - u0 ) - if ( abs(u1_l) .GT. abs(slope) ) then + if ( abs(u1_l) > abs(slope) ) then u1_l = slope end if @@ -502,11 +504,11 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) exp1 = (u0_r - u0_l) * (u1 - 0.5*(u0_l+u0_r)) exp2 = (u0_r - u0_l) * (u0_r - u0_l) / 6.0 - if ( exp1 .GT. exp2 ) then + if ( exp1 > exp2 ) then u0_l = 3.0 * u1 - 2.0 * u0_r end if - if ( exp1 .LT. -exp2 ) then + if ( exp1 < -exp2 ) then u0_r = 3.0 * u1 - 2.0 * u0_l end if @@ -518,19 +520,18 @@ subroutine PQM_boundary_extrapolation( N, h, u, ppoly_E, ppoly_coefficients ) c = 3.0 * ( u0_r + u0_l - 2.0 * u1 ) ! The quartic is reduced to a parabola in the boundary cell - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c - ppoly_coefficients(i1,4) = 0.0 - ppoly_coefficients(i1,5) = 0.0 + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = 0.0 + ppoly_coef(i1,5) = 0.0 end subroutine PQM_boundary_extrapolation !------------------------------------------------------------------------------ -! pqm boundary extrapolation using rational function -! ----------------------------------------------------------------------------- -subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coefficients, h_neglect ) +!> pqm boundary extrapolation using a rational function +subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coef, h_neglect ) !------------------------------------------------------------------------------ ! Reconstruction by parabolas within boundary cells. ! @@ -554,15 +555,18 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff !------------------------------------------------------------------------------ ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: h ! cell widths (size N) - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: ppoly_E !Edge value of polynomial - real, dimension(:,:), intent(inout) :: ppoly_S !Edge slope of polynomial - real, dimension(:,:), intent(inout) :: ppoly_coefficients !Coefficients of polynomial - real, optional, intent(in) :: h_neglect !< A negligibly small width for - !! the purpose of cell reconstructions - !! in the same units as h. + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: ppoly_E !< Edge value of polynomial, + !! with the same units as u. + real, dimension(:,:), intent(inout) :: ppoly_S !< Edge slope of polynomial, + !! in the units of u over the units of h. + real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width for + !! the purpose of cell reconstructions + !! in the same units as h. ! Local variables integer :: i0, i1 @@ -600,15 +604,15 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! The right edge value and slope of the boundary cell are taken to be the ! left edge value and slope of the adjacent cell - a = ppoly_coefficients(i1,1) - b = ppoly_coefficients(i1,2) + a = ppoly_coef(i1,1) + b = ppoly_coef(i1,2) u0_r = a ! edge value u1_r = b / (h1 + hNeglect) ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and right ! edge value and slope - if (u1_r.ne.0.) then ! HACK by AJA + if (u1_r /= 0.) then ! HACK by AJA beta = 2.0 * ( u0_r - um ) / ( (h0 + hNeglect)*u1_r) - 1.0 else beta = 0. @@ -626,7 +630,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the PLM edge value. If so, keep it and compute left edge slope ! based on the rational function. If not, keep the PLM edge value and ! compute corresponding slope. - if ( abs(um-u0_l) .lt. abs(um-u_plm) ) then + if ( abs(um-u0_l) < abs(um-u_plm) ) then u1_l = 2.0 * ( br - ar*beta) u1_l = u1_l / (h0 + hNeglect) else @@ -651,41 +655,41 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Check whether inflexion points exist. If so, transform the quartic ! so that both inflexion points coalesce on the left edge. - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 - if ( (x1 .gt. 0.0) .and. (x1 .lt. 1.0) ) then + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 end if end if x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 - if ( (x2 .gt. 0.0) .and. (x2 .lt. 1.0) ) then + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b - if ( gradient2 * slope .lt. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then inflexion_l = 1 end if end if end if - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .and. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_l = 1 end if end if end if - if ( inflexion_l .eq. 1 ) then + if ( inflexion_l == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the left edge @@ -696,13 +700,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the left edge - if ( u1_l * slope .LT. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = 5.0 * um - 4.0 * u0_l u1_r = 20.0 * (um - u0_l) / ( h0 + hNeglect ) - else if ( u1_r * slope .LT. 0.0 ) then + else if ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = (5.0*um - 3.0*u0_r) / 2.0 @@ -725,11 +729,11 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff e = 30.0 * um + 2.5*h0*(u1_r - u1_l) - 15.0*(u0_l + u0_r) ! Store coefficients - ppoly_coefficients(i0,1) = a - ppoly_coefficients(i0,2) = b - ppoly_coefficients(i0,3) = c - ppoly_coefficients(i0,4) = d - ppoly_coefficients(i0,5) = e + ppoly_coef(i0,1) = a + ppoly_coef(i0,2) = b + ppoly_coef(i0,3) = c + ppoly_coef(i0,4) = d + ppoly_coef(i0,5) = e ! ----- Right boundary (BOTTOM) ----- i0 = N-1 @@ -747,17 +751,17 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! The left edge value and slope of the boundary cell are taken to be the ! right edge value and slope of the adjacent cell - a = ppoly_coefficients(i0,1) - b = ppoly_coefficients(i0,2) - c = ppoly_coefficients(i0,3) - d = ppoly_coefficients(i0,4) - e = ppoly_coefficients(i0,5) + a = ppoly_coef(i0,1) + b = ppoly_coef(i0,2) + c = ppoly_coef(i0,3) + d = ppoly_coef(i0,4) + e = ppoly_coef(i0,5) u0_l = a + b + c + d + e ! edge value u1_l = (b + 2*c + 3*d + 4*e) / h0 ! edge slope (w.r.t. global coord.) ! Compute coefficient for rational function based on mean and left ! edge value and slope - if (um-u0_l.ne.0.) then ! HACK by AJA + if (um-u0_l /= 0.) then ! HACK by AJA beta = 0.5*h1*u1_l / (um-u0_l) - 1.0 else beta = 0. @@ -766,7 +770,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ar = u0_l ! Right edge value estimate based on rational function - if (1+beta.ne.0.) then ! HACK by AJA + if (1+beta /= 0.) then ! HACK by AJA u0_r = (ar + 2*br + beta*br ) / ((1+beta)*(1+beta)) else u0_r = um + 0.5 * slope ! PLM @@ -779,7 +783,7 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the PLM edge value. If so, keep it and compute right edge slope ! based on the rational function. If not, keep the PLM edge value and ! compute corresponding slope. - if ( abs(um-u0_r) .lt. abs(um-u_plm) ) then + if ( abs(um-u0_r) < abs(um-u_plm) ) then u1_r = 2.0 * ( br - ar*beta ) / ( (1+beta)*(1+beta)*(1+beta) ) u1_r = u1_r / h1 else @@ -804,41 +808,41 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! Check whether inflexion points exist. If so, transform the quartic ! so that both inflexion points coalesce on the right edge. - if (( alpha1 .ne. 0.0 ) .and. ( rho .ge. 0.0 )) then + if (( alpha1 /= 0.0 ) .and. ( rho >= 0.0 )) then sqrt_rho = sqrt( rho ) x1 = 0.5 * ( - alpha2 - sqrt_rho ) / alpha1 - if ( (x1 .gt. 0.0) .and. (x1 .lt. 1.0) ) then + if ( (x1 > 0.0) .and. (x1 < 1.0) ) then gradient1 = 4.0 * e * (x1**3) + 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 end if end if x2 = 0.5 * ( - alpha2 + sqrt_rho ) / alpha1 - if ( (x2 .gt. 0.0) .and. (x2 .lt. 1.0) ) then + if ( (x2 > 0.0) .and. (x2 < 1.0) ) then gradient2 = 4.0 * e * (x2**3) + 3.0 * d * (x2**2) + 2.0 * c * x2 + b - if ( gradient2 * slope .lt. 0.0 ) then + if ( gradient2 * slope < 0.0 ) then inflexion_r = 1 end if end if end if - if (( alpha1 .eq. 0.0 ) .and. ( alpha2 .ne. 0.0 )) then + if (( alpha1 == 0.0 ) .and. ( alpha2 /= 0.0 )) then x1 = - alpha3 / alpha2 - if ( (x1 .ge. 0.0) .and. (x1 .le. 1.0) ) then + if ( (x1 >= 0.0) .and. (x1 <= 1.0) ) then gradient1 = 3.0 * d * (x1**2) + 2.0 * c * x1 + b - if ( gradient1 * slope .lt. 0.0 ) then + if ( gradient1 * slope < 0.0 ) then inflexion_r = 1 end if end if end if - if ( inflexion_r .eq. 1 ) then + if ( inflexion_r == 1 ) then ! We modify the edge slopes so that both inflexion points ! collapse onto the right edge @@ -849,13 +853,13 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff ! the inconsistent slope is set equal to zero and the opposite edge value ! and edge slope are modified in compliance with the fact that both ! inflexion points must still be located on the right edge - if ( u1_l * slope .lt. 0.0 ) then + if ( u1_l * slope < 0.0 ) then u1_l = 0.0 u0_r = ( 5.0 * um - 3.0 * u0_l ) / 2.0 u1_r = 10.0 * (um - u0_l) / (3.0 * h1) - else if ( u1_r * slope .lt. 0.0 ) then + else if ( u1_r * slope < 0.0 ) then u1_r = 0.0 u0_l = 5.0 * um - 4.0 * u0_r @@ -877,11 +881,11 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, ppoly_E, ppoly_S, ppoly_coeff d = -60.0 * um + h1 *(6.0*u1_l - 4.0*u1_r) + 28.0*u0_r + 32.0*u0_l e = 30.0 * um + 2.5*h1*(u1_r - u1_l) - 15.0*(u0_l + u0_r) - ppoly_coefficients(i1,1) = a - ppoly_coefficients(i1,2) = b - ppoly_coefficients(i1,3) = c - ppoly_coefficients(i1,4) = d - ppoly_coefficients(i1,5) = e + ppoly_coef(i1,1) = a + ppoly_coef(i1,2) = b + ppoly_coef(i1,3) = c + ppoly_coef(i1,4) = d + ppoly_coef(i1,5) = e end subroutine PQM_boundary_extrapolation_v1 diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 2e5b4156c8..b2ae0c6de4 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -12,8 +12,7 @@ module coord_adapt #include -type, public :: adapt_CS - private +type, public :: adapt_CS ; private !> Number of layers/levels integer :: nk @@ -51,8 +50,8 @@ module coord_adapt !> Initialise an adapt_CS with parameters subroutine init_coord_adapt(CS, nk, coordinateResolution) type(adapt_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution (m) if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) @@ -72,12 +71,21 @@ subroutine end_coord_adapt(CS) deallocate(CS) end subroutine end_coord_adapt +!> This subtroutine can be used to set the parameters for coord_adapt module subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff, & - adaptBuoyCoeff, adaptDrho0, adaptDoMin) + adaptBuoyCoeff, adaptDrho0, adaptDoMin) type(adapt_CS), pointer :: CS !< The control structure for this module - real, optional, intent(in) :: adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff - real, optional, intent(in) :: adaptBuoyCoeff, adaptDrho0 - logical, optional, intent(in) :: adaptDoMin + real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales + real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining + !! how much optimisation to apply + real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth, in m + real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient + real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient + real, optional, intent(in) :: adaptDrho0 !< Reference density difference for + !! stratification-dependent diffusion + logical, optional, intent(in) :: adaptDoMin !< If true, form a HYCOM1-like mixed layer by + !! preventing interfaces from becoming shallower than + !! the depths set by coordinateResolution if (.not. associated(CS)) call MOM_error(FATAL, "set_adapt_params: CS not associated") diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 06da6db4b2..aad807b62d 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -10,8 +10,7 @@ module coord_hycom implicit none ; private !> Control structure containing required parameters for the HyCOM coordinate -type, public :: hycom_CS - private +type, public :: hycom_CS ; private !> Number of layers/levels in generated grid integer :: nk @@ -40,7 +39,7 @@ module coord_hycom subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp_CS) type(hycom_CS), pointer :: CS !< Unassociated pointer to hold the control structure integer, intent(in) :: nk !< Number of layers in generated grid - real, dimension(nk), intent(in) :: coordinateResolution !< Z-space thicknesses (m) + real, dimension(nk), intent(in) :: coordinateResolution !< Nominal near-surface resolution (m) real, dimension(nk+1),intent(in) :: target_density !< Interface target densities (kg/m3) type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation @@ -55,8 +54,9 @@ subroutine init_coord_hycom(CS, nk, coordinateResolution, target_density, interp CS%interp_CS = interp_CS end subroutine init_coord_hycom +!> This subroutine deallocates memory in the control structure for the coord_hycom module subroutine end_coord_hycom(CS) - type(hycom_CS), pointer :: CS + type(hycom_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -67,11 +67,12 @@ subroutine end_coord_hycom(CS) deallocate(CS) end subroutine end_coord_hycom +!> This subroutine can be used to set the parameters for the coord_hycom module subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) - type(hycom_CS), pointer :: CS - real, optional, dimension(:), intent(in) :: max_interface_depths - real, optional, dimension(:), intent(in) :: max_layer_thickness - type(interp_CS_type), optional, intent(in) :: interp_CS + type(hycom_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces in m + real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers in m + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index bee6832f77..d3141cfd2d 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -11,23 +11,22 @@ module coord_rho implicit none ; private !> Control structure containing required parameters for the rho coordinate -type, public :: rho_CS - private +type, public :: rho_CS ; private !> Number of layers integer :: nk - !> Minimum thickness allowed for layers + !> Minimum thickness allowed for layers, in m real :: min_thickness = 0. - !> Reference pressure for density calculations + !> Reference pressure for density calculations, in Pa real :: ref_pressure !> If true, integrate for interface positions from the top downward. !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .false. - !> Nominal density of interfaces + !> Nominal density of interfaces, in kg m-3 real, allocatable, dimension(:) :: target_density !> Interpolation control structure @@ -46,10 +45,10 @@ module coord_rho !> Initialise a rho_CS with pointers to parameters subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) type(rho_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, intent(in) :: ref_pressure - real, dimension(:), intent(in) :: target_density - type(interp_CS_type), intent(in) :: interp_CS + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Nominal density of interfaces in Pa + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces in kg m-3 + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_rho: CS already associated!") allocate(CS) @@ -61,8 +60,9 @@ subroutine init_coord_rho(CS, nk, ref_pressure, target_density, interp_CS) CS%interp_CS = interp_CS end subroutine init_coord_rho +!> This subroutine deallocates memory in the control structure for the coord_rho module subroutine end_coord_rho(CS) - type(rho_CS), pointer :: CS + type(rho_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -70,11 +70,15 @@ subroutine end_coord_rho(CS) deallocate(CS) end subroutine end_coord_rho +!> This subroutine can be used to set the parameters for the coord_rho module subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS) - type(rho_CS), pointer :: CS - real, optional, intent(in) :: min_thickness - logical, optional, intent(in) :: integrate_downward_for_e - type(interp_CS_type), optional, intent(in) :: interp_CS + type(rho_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness, in m + logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface + !! positions from the top downward. If false, integrate + !! from the bottom upward, as does the rest of the model. + + type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_rho_params: CS not associated") @@ -342,14 +346,13 @@ subroutine copy_finite_thicknesses(nk, h_in, threshold, nout, h_out, mapping) end subroutine copy_finite_thicknesses !------------------------------------------------------------------------------ -! Inflate vanished layers to finite (nonzero) width -!------------------------------------------------------------------------------ -subroutine old_inflate_layers_1d( minThickness, N, h ) +!> Inflate vanished layers to finite (nonzero) width +subroutine old_inflate_layers_1d( min_thickness, nk, h ) ! Argument - real, intent(in) :: minThickness - integer, intent(in) :: N - real, intent(inout) :: h(:) + real, intent(in) :: min_thickness !< Minimum allowed thickness, in m + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(inout) :: h !< Layer thicknesses, in m ! Local variable integer :: k @@ -361,28 +364,28 @@ subroutine old_inflate_layers_1d( minThickness, N, h ) ! Count number of nonzero layers count_nonzero_layers = 0 - do k = 1,N - if ( h(k) > minThickness ) then + do k = 1,nk + if ( h(k) > min_thickness ) then count_nonzero_layers = count_nonzero_layers + 1 end if end do ! If all layer thicknesses are greater than the threshold, exit routine - if ( count_nonzero_layers == N ) return + if ( count_nonzero_layers == nk ) return ! If all thicknesses are zero, inflate them all and exit if ( count_nonzero_layers == 0 ) then - do k = 1,N - h(k) = minThickness + do k = 1,nk + h(k) = min_thickness end do return end if ! Inflate zero layers correction = 0.0 - do k = 1,N - if ( h(k) <= minThickness ) then - delta = minThickness - h(k) + do k = 1,nk + if ( h(k) <= min_thickness ) then + delta = min_thickness - h(k) correction = correction + delta h(k) = h(k) + delta end if @@ -391,7 +394,7 @@ subroutine old_inflate_layers_1d( minThickness, N, h ) ! Modify thicknesses of nonzero layers to ensure volume conservation maxThickness = h(1) k_found = 1 - do k = 1,N + do k = 1,nk if ( h(k) > maxThickness ) then maxThickness = h(k) k_found = k diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index 416ab757e2..bbb6312ba4 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -8,8 +8,7 @@ module coord_sigma implicit none ; private !> Control structure containing required parameters for the sigma coordinate -type, public :: sigma_CS - private +type, public :: sigma_CS ; private !> Number of levels integer :: nk @@ -28,8 +27,8 @@ module coord_sigma !> Initialise a sigma_CS with pointers to parameters subroutine init_coord_sigma(CS, nk, coordinateResolution) type(sigma_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of layers in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Nominal coordinate resolution (nondim) if (associated(CS)) call MOM_error(FATAL, "init_coord_sigma: CS already associated!") allocate(CS) @@ -39,8 +38,9 @@ subroutine init_coord_sigma(CS, nk, coordinateResolution) CS%coordinateResolution = coordinateResolution end subroutine init_coord_sigma +!> This subroutine deallocates memory in the control structure for the coord_sigma module subroutine end_coord_sigma(CS) - type(sigma_CS), pointer :: CS + type(sigma_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -48,9 +48,10 @@ subroutine end_coord_sigma(CS) deallocate(CS) end subroutine end_coord_sigma +!> This subroutine can be used to set the parameters for the coord_sigma module subroutine set_sigma_params(CS, min_thickness) - type(sigma_CS), pointer :: CS - real, optional, intent(in) :: min_thickness + type(sigma_CS), pointer :: CS !< Coordinate control structure + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness, in m if (.not. associated(CS)) call MOM_error(FATAL, "set_sigma_params: CS not associated") @@ -63,7 +64,7 @@ subroutine build_sigma_column(CS, depth, totalThickness, zInterface) type(sigma_CS), intent(in) :: CS !< Coordinate control structure real, intent(in) :: depth !< Depth of ocean bottom (positive in m) real, intent(in) :: totalThickness !< Column thickness (positive in m) - real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces in m ! Local variables integer :: k diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 index 93f5b9c393..ba0bdb0326 100644 --- a/src/ALE/coord_slight.F90 +++ b/src/ALE/coord_slight.F90 @@ -12,13 +12,12 @@ module coord_slight implicit none ; private !> Control structure containing required parameters for the SLight coordinate -type, public :: slight_CS - private +type, public :: slight_CS ; private !> Number of layers/levels integer :: nk - !> Minimum thickness allowed when building the new grid through regridding + !> Minimum thickness allowed when building the new grid through regridding (m) real :: min_thickness !> Reference pressure for potential density calculations (Pa) @@ -35,7 +34,7 @@ module coord_slight !> Number of layers to offset the mixed layer density to find resolved stratification (nondim) real :: nlay_ml_offset = 2.0 - !> The number of fixed-thickess layers at the top of the model + !> The number of fixed-thickness layers at the top of the model integer :: nz_fixed_surface = 2 !> The fixed resolution in the topmost SLight_nkml_min layers (m) @@ -49,16 +48,16 @@ module coord_slight !! unstable water mass profiles, in m. real :: halocline_filter_length = 2.0 - !> A value of the stratification ratio that defines a problematic halocline region. + !> A value of the stratification ratio that defines a problematic halocline region (nondim). real :: halocline_strat_tol = 0.25 - !> Nominal density of interfaces + !> Nominal density of interfaces, in kg m-3. real, allocatable, dimension(:) :: target_density - !> Maximum depths of interfaces + !> Maximum depths of interfaces, in m. real, allocatable, dimension(:) :: max_interface_depths - !> Maximum thicknesses of layers + !> Maximum thicknesses of layers, in m. real, allocatable, dimension(:) :: max_layer_thickness !> Interpolation control structure @@ -72,10 +71,10 @@ module coord_slight !> Initialise a slight_CS with pointers to parameters subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS) type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, intent(in) :: ref_pressure - real, dimension(:), intent(in) :: target_density - type(interp_CS_type), intent(in) :: interp_CS + integer, intent(in) :: nk !< Number of layers in the grid + real, intent(in) :: ref_pressure !< Nominal density of interfaces in Pa + real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces in kg m-3 + type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation if (associated(CS)) call MOM_error(FATAL, "init_coord_slight: CS already associated!") allocate(CS) @@ -87,8 +86,9 @@ subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS) CS%interp_CS = interp_CS end subroutine init_coord_slight +!> This subroutine deallocates memory in the control structure for the coord_slight module subroutine end_coord_slight(CS) - type(slight_CS), pointer :: CS + type(slight_CS), pointer :: CS !< Coordinate control structure ! nothing to do if (.not. associated(CS)) return @@ -96,23 +96,37 @@ subroutine end_coord_slight(CS) deallocate(CS) end subroutine end_coord_slight +!> This subroutine can be used to set the parameters for the coord_slight module subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & - min_thickness, compressibility_fraction, & - dz_ml_min, nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & - halocline_filter_length, halocline_strat_tol, interp_CS) - type(slight_CS), pointer :: CS - real, optional, dimension(:), intent(in) :: max_interface_depths - real, optional, dimension(:), intent(in) :: max_layer_thickness - real, optional, intent(in) :: min_thickness - real, optional, intent(in) :: compressibility_fraction - real, optional, intent(in) :: dz_ml_min - integer, optional, intent(in) :: nz_fixed_surface - real, optional, intent(in) :: Rho_ML_avg_depth - real, optional, intent(in) :: nlay_ML_offset - logical, optional, intent(in) :: fix_haloclines - real, optional, intent(in) :: halocline_filter_length - real, optional, intent(in) :: halocline_strat_tol - type(interp_CS_type), optional, intent(in) :: interp_CS + min_thickness, compressibility_fraction, dz_ml_min, & + nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & + halocline_filter_length, halocline_strat_tol, interp_CS) + type(slight_CS), pointer :: CS !< Coordinate control structure + real, dimension(:), & + optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces in m + real, dimension(:), & + optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers in m + real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the + !! new grid through regridding, in m + real, optional, intent(in) :: compressibility_fraction !< Fraction (between 0 and 1) of + !! compressibility to add to potential density profiles when + !! interpolating for target grid positions. (nondim) + real, optional, intent(in) :: dz_ml_min !< The fixed resolution in the topmost + !! SLight_nkml_min layers (m) + integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the + !! top of the model + real, optional, intent(in) :: Rho_ML_avg_depth !< Depth over which to average to determine + !! the mixed layer potential density (m) + real, optional, intent(in) :: nlay_ML_offset !< Number of layers to offset the mixed layer + !! density to find resolved stratification (nondim) + logical, optional, intent(in) :: fix_haloclines !< If true, detect regions with much weaker than + !! based on in-situ density, and use a stretched coordinate there. + real, optional, intent(in) :: halocline_filter_length !< A length scale over which to filter T & S + !! when looking for spuriously unstable water mass profiles, in m. + real, optional, intent(in) :: halocline_strat_tol !< A value of the stratification ratio that + !! defines a problematic halocline region (nondim). + type(interp_CS_type), & + optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_slight_params: CS not associated") diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index 41fb61f6c3..7eafb5d5a6 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -28,8 +28,8 @@ module coord_zlike !> Initialise a zlike_CS with pointers to parameters subroutine init_coord_zlike(CS, nk, coordinateResolution) type(zlike_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk - real, dimension(:), intent(in) :: coordinateResolution + integer, intent(in) :: nk !< Number of levels in the grid + real, dimension(:), intent(in) :: coordinateResolution !< Target coordinate resolution, in m if (associated(CS)) call MOM_error(FATAL, "init_coord_zlike: CS already associated!") allocate(CS) @@ -52,7 +52,7 @@ end subroutine end_coord_zlike !> Set parameters in the zlike structure subroutine set_zlike_params(CS, min_thickness) type(zlike_CS), pointer :: CS !< Coordinate control structure - real, optional, intent(in) :: min_thickness !< Minimum allowed thickness + real, optional, intent(in) :: min_thickness !< Minimum allowed thickness, in m if (.not. associated(CS)) call MOM_error(FATAL, "set_zlike_params: CS not associated") diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90 index b0d5d135d5..0cc4eb0b71 100644 --- a/src/ALE/polynomial_functions.F90 +++ b/src/ALE/polynomial_functions.F90 @@ -21,62 +21,58 @@ module polynomial_functions contains ! ----------------------------------------------------------------------------- -! Pointwise evaluation of a polynomial -! ----------------------------------------------------------------------------- -real function evaluation_polynomial( coefficients, nb_coefficients, x ) +!> Pointwise evaluation of a polynomial at x +real function evaluation_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the polynomial ! ----------------------------------------------------------------------------- ! The polynomial is defined by the coefficients contained in the ! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... -! where C refers to the array 'coefficients'. -! The number of coefficients is given by nb_coefficients and x +! where C refers to the array 'coeff'. +! The number of coefficients is given by ncoef and x ! is the coordinate where the polynomial is to be evaluated. ! ! The function returns the value of the polynomial at x. ! ----------------------------------------------------------------------------- ! Arguments - real, dimension(:), intent(in) :: coefficients - integer, intent(in) :: nb_coefficients - real, intent(in) :: x ! Local variables - integer :: k - real :: f ! value of polynomial at x + integer :: k + real :: f ! value of polynomial at x f = 0.0 - do k = 1,nb_coefficients - f = f + coefficients(k) * ( x**(k-1) ) + do k = 1,ncoef + f = f + coeff(k) * ( x**(k-1) ) end do evaluation_polynomial = f end function evaluation_polynomial -!> Calculates the first derivative of a polynomial with coefficients as above -!! evaluated at a point x -real function first_derivative_polynomial( coefficients, nb_coefficients, x ) +!> Calculates the first derivative of a polynomial evaluated at a point x +real function first_derivative_polynomial( coeff, ncoef, x ) + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + integer, intent(in) :: ncoef !< The number of polynomial coefficients + real, intent(in) :: x !< The position at which to evaluate the derivative ! ----------------------------------------------------------------------------- ! The polynomial is defined by the coefficients contained in the ! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... -! where C refers to the array 'coefficients'. -! The number of coefficients is given by nb_coefficients and x +! where C refers to the array 'coeff'. +! The number of coefficients is given by ncoef and x ! is the coordinate where the polynomial's derivative is to be evaluated. ! -! The function returns the value of the polynomial at x. +! The function returns the first derivative of the polynomial at x. ! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:), intent(in) :: coefficients - integer, intent(in) :: nb_coefficients - real, intent(in) :: x - ! Local variables integer :: k real :: f ! value of polynomial at x f = 0.0 - do k = 2,nb_coefficients - f = f + REAL(k-1)*coefficients(k) * ( x**(k-2) ) + do k = 2,ncoef + f = f + REAL(k-1)*coeff(k) * ( x**(k-2) ) end do first_derivative_polynomial = f @@ -84,48 +80,45 @@ real function first_derivative_polynomial( coefficients, nb_coefficients, x ) end function first_derivative_polynomial ! ----------------------------------------------------------------------------- -! Exact integration of polynomial of degree n -! ----------------------------------------------------------------------------- -real function integration_polynomial( xi0, xi1, C, n ) +!> Exact integration of polynomial of degree npoly +real function integration_polynomial( xi0, xi1, Coeff, npoly ) + real, intent(in) :: xi0 !< The lower bound of the integral + real, intent(in) :: xi1 !< The lower bound of the integral + real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial + integer, intent(in) :: npoly !< The degree of the polynomial ! ----------------------------------------------------------------------------- -! Exact integration of a polynomial of degree n over the interval [xi0,xi1]. -! The array of coefficients (C) must be of size n+1, where n is the degree of -! the polynomial to integrate. +! Exact integration of a polynomial of degree npoly over the interval [xi0,xi1]. +! The array of coefficients (Coeff) must be of size npoly+1. ! ----------------------------------------------------------------------------- - ! Arguments - real, intent(in) :: xi0, xi1 - real, dimension(:), intent(in) :: C - integer, intent(in) :: n - ! Local variables integer :: k real :: integral integral = 0.0 - do k = 1,(n+1) - integral = integral + C(k) * (xi1**k - xi0**k) / real(k) + do k = 1,npoly+1 + integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) end do ! !One non-answer-changing way of unrolling the above is: ! k=1 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) -! if (n>=1) then +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) +! if (npoly>=1) then ! k=2 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=2) then +! if (npoly>=2) then ! k=3 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=3) then +! if (npoly>=3) then ! k=4 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif -! if (n>=4) then +! if (npoly>=4) then ! k=5 -! integral = integral + C(k) * (xi1**k - xi0**k) / real(k) +! integral = integral + Coeff(k) * (xi1**k - xi0**k) / real(k) ! endif ! integration_polynomial = integral diff --git a/src/ALE/regrid_edge_slopes.F90 b/src/ALE/regrid_edge_slopes.F90 index f8781aa937..e07f3c3bd5 100644 --- a/src/ALE/regrid_edge_slopes.F90 +++ b/src/ALE/regrid_edge_slopes.F90 @@ -32,6 +32,13 @@ module regrid_edge_slopes !------------------------------------------------------------------------------ !> Compute ih4 edge slopes (implicit third order accurate) subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Compute edge slopes based on third-order implicit estimates. Note that ! the estimates are fourth-order accurate on uniform grids @@ -58,15 +65,6 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect ) ! boundary conditions close the system. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths @@ -188,6 +186,13 @@ end subroutine edge_slopes_implicit_h3 !------------------------------------------------------------------------------ !> Compute ih5 edge values (implicit fifth order accurate) subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the + !! same units as u divided by the units of h. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Fifth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -221,15 +226,6 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect ) ! on nonuniform meshes turned out to be intractable. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_slopes !< Returned edge slopes, with the - !! same units as u divided by the units of h. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index fafb873a6c..d43cf5cc36 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -43,9 +43,15 @@ module regrid_edge_values contains !------------------------------------------------------------------------------ -! Bound edge values by neighboring cell averages -!------------------------------------------------------------------------------ -subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) +!> Bound edge values by neighboring cell averages +subroutine bound_edge_values( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Potentially modified edge values, + !! with the same units as u. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ------------------------------------------------------------------------------ ! In this routine, we loop on all cells to bound their left and right ! edge values by the cell averages. That is, the left edge value must lie @@ -57,15 +63,6 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! Therefore, boundary cells are treated as if they were local extrama. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values, - !! with the same units as u. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: k ! loop index integer :: k0, k1, k2 @@ -88,11 +85,11 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! boundary cell and the right neighbor of the right boundary cell ! is assumed to be the same as the right boundary cell. This ! effectively makes boundary cells look like extrema. - if ( k .EQ. 1 ) then + if ( k == 1 ) then k0 = 1 k1 = 1 k2 = 2 - else if ( k .EQ. N ) then + else if ( k == N ) then k0 = N-1 k1 = N k2 = N @@ -111,14 +108,14 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) u_c = u(k1) u_r = u(k2) - u0_l = edge_values(k,1) - u0_r = edge_values(k,2) + u0_l = edge_val(k,1) + u0_r = edge_val(k,2) sigma_l = 2.0 * ( u_c - u_l ) / ( h_c + hNeglect ) sigma_c = 2.0 * ( u_r - u_l ) / ( h_l + 2.0*h_c + h_r + hNeglect ) sigma_r = 2.0 * ( u_r - u_c ) / ( h_c + hNeglect ) - if ( (sigma_l * sigma_r) .GT. 0.0 ) then + if ( (sigma_l * sigma_r) > 0.0 ) then slope = sign( min(abs(sigma_l),abs(sigma_c),abs(sigma_r)), sigma_c ) else slope = 0.0 @@ -130,11 +127,11 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) ! JCP 2008 Eqs 19 and 20) slope = slope * h_c * 0.5 - if ( (u_l-u0_l)*(u0_l-u_c) .LT. 0.0 ) then + if ( (u_l-u0_l)*(u0_l-u_c) < 0.0 ) then u0_l = u_c - sign( min( abs(slope), abs(u0_l-u_c) ), slope ) end if - if ( (u_r-u0_r)*(u0_r-u_c) .LT. 0.0 ) then + if ( (u_r-u0_r)*(u0_r-u_c) < 0.0 ) then u0_r = u_c + sign( min( abs(slope), abs(u0_r-u_c) ), slope ) end if @@ -143,8 +140,8 @@ subroutine bound_edge_values( N, h, u, edge_values, h_neglect ) u0_r = max( min( u0_r, max(u_r, u_c) ), min(u_r, u_c) ) ! Store edge values - edge_values(k,1) = u0_l - edge_values(k,2) = u0_r + edge_val(k,1) = u0_l + edge_val(k,2) = u0_r end do ! loop on interior edges @@ -152,18 +149,16 @@ end subroutine bound_edge_values !------------------------------------------------------------------------------ -! Average discontinuous edge values (systematically) -!------------------------------------------------------------------------------ -subroutine average_discontinuous_edge_values( N, edge_values ) +!> Replace discontinuous collocated edge values with their average +subroutine average_discontinuous_edge_values( N, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(:,:), intent(inout) :: edge_val !< Edge values that may be modified + !! the second index size is 2. ! ------------------------------------------------------------------------------ ! For each interior edge, check whether the edge values are discontinuous. -! If so, compute the average and replace the edge values by the average.! +! If so, compute the average and replace the edge values by the average. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:,:), intent(inout) :: edge_values - ! Local variables integer :: k ! loop index real :: u0_minus ! left value at given edge @@ -174,15 +169,15 @@ subroutine average_discontinuous_edge_values( N, edge_values ) do k = 1,N-1 ! Edge value on the left of the edge - u0_minus = edge_values(k,2) + u0_minus = edge_val(k,2) ! Edge value on the right of the edge - u0_plus = edge_values(k+1,1) + u0_plus = edge_val(k+1,1) - if ( u0_minus .NE. u0_plus ) then + if ( u0_minus /= u0_plus ) then u0_avg = 0.5 * ( u0_minus + u0_plus ) - edge_values(k,2) = u0_avg - edge_values(k+1,1) = u0_avg + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg end if end do ! end loop on interior edges @@ -191,19 +186,16 @@ end subroutine average_discontinuous_edge_values !------------------------------------------------------------------------------ -! Check discontinuous edge values and take average is not monotonic -!------------------------------------------------------------------------------ -subroutine check_discontinuous_edge_values( N, u, edge_values ) +!> Check discontinuous edge values and replace them with their average if not monotonic +subroutine check_discontinuous_edge_values( N, u, edge_val ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Cell edge values with the same units as u. ! ------------------------------------------------------------------------------ ! For each interior edge, check whether the edge values are discontinuous. ! If so and if they are not monotonic, replace each edge value by their average. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N ! Number of cells - real, dimension(:), intent(in) :: u ! cell averages (size N) - real, dimension(:,:), intent(inout) :: edge_values - ! Local variables integer :: k ! loop index real :: u0_minus ! left value at given edge @@ -216,10 +208,10 @@ subroutine check_discontinuous_edge_values( N, u, edge_values ) do k = 1,N-1 ! Edge value on the left of the edge - u0_minus = edge_values(k,2) + u0_minus = edge_val(k,2) ! Edge value on the right of the edge - u0_plus = edge_values(k+1,1) + u0_plus = edge_val(k+1,1) ! Left cell average um_minus = u(k) @@ -227,11 +219,11 @@ subroutine check_discontinuous_edge_values( N, u, edge_values ) ! Right cell average um_plus = u(k+1) - if ( (u0_plus - u0_minus)*(um_plus - um_minus) .LT. 0.0 ) then + if ( (u0_plus - u0_minus)*(um_plus - um_minus) < 0.0 ) then u0_avg = 0.5 * ( u0_minus + u0_plus ) u0_avg = max( min( u0_avg, max(um_minus, um_plus) ), min(um_minus, um_plus) ) - edge_values(k,2) = u0_avg - edge_values(k+1,1) = u0_avg + edge_val(k,2) = u0_avg + edge_val(k+1,1) = u0_avg end if end do ! end loop on interior edges @@ -241,7 +233,14 @@ end subroutine check_discontinuous_edge_values !------------------------------------------------------------------------------ !> Compute h2 edge values (explicit second order accurate) -subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) +subroutine edge_values_explicit_h2( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ------------------------------------------------------------------------------ ! Compute edge values based on second-order explicit estimates. ! These estimates are based on a straight line spanning two cells and evaluated @@ -255,15 +254,6 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) ! Boundary edge values are set to be equal to the boundary cell averages. ! ------------------------------------------------------------------------------ - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: k ! loop index real :: h0, h1 ! cell widths @@ -288,24 +278,31 @@ subroutine edge_values_explicit_h2( N, h, u, edge_values, h_neglect ) u1 = u(k) ! Compute left edge value - edge_values(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) + edge_val(k,1) = ( u0*h1 + u1*h0 ) / ( h0 + h1 ) ! Left edge value of the current cell is equal to right edge ! value of left cell - edge_values(k-1,2) = edge_values(k,1) + edge_val(k-1,2) = edge_val(k,1) end do ! end loop on interior cells ! Boundary edge values are simply equal to the boundary cell averages - edge_values(1,1) = u(1) - edge_values(N,2) = u(N) + edge_val(1,1) = u(1) + edge_val(N,2) = u(N) end subroutine edge_values_explicit_h2 !------------------------------------------------------------------------------ !> Compute h4 edge values (explicit fourth order accurate) -subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) +subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order explicit estimates. ! These estimates are based on a cubic interpolant spanning four cells @@ -325,15 +322,6 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) ! For this fourth-order scheme, at least four cells must exist. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j real :: u0, u1, u2, u3 @@ -387,8 +375,8 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) e = e / ( h0 + h1 + h2 + h3) - edge_values(i,1) = e - edge_values(i-1,2) = e + edge_val(i,1) = e + edge_val(i-1,2) = e #ifdef __DO_SAFETY_CHECKS__ if (e /= e) then @@ -422,14 +410,14 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) call solve_linear_system( A, B, C, 4 ) ! First edge value - edge_values(1,1) = evaluation_polynomial( C, 4, x(1) ) + edge_val(1,1) = evaluation_polynomial( C, 4, x(1) ) ! Second edge value - edge_values(1,2) = evaluation_polynomial( C, 4, x(2) ) - edge_values(2,1) = edge_values(1,2) + edge_val(1,2) = evaluation_polynomial( C, 4, x(2) ) + edge_val(2,1) = edge_val(1,2) #ifdef __DO_SAFETY_CHECKS__ - if (edge_values(1,1) /= edge_values(1,1) .or. edge_values(1,2) /= edge_values(1,2)) then + if (edge_val(1,1) /= edge_val(1,1) .or. edge_val(1,2) /= edge_val(1,2)) then write(0,*) 'NaN in explicit_edge_h4 at k=',1 write(0,*) 'A=',A write(0,*) 'B=',B @@ -460,14 +448,14 @@ subroutine edge_values_explicit_h4( N, h, u, edge_values, h_neglect ) call solve_linear_system( A, B, C, 4 ) ! Last edge value - edge_values(N,2) = evaluation_polynomial( C, 4, x(5) ) + edge_val(N,2) = evaluation_polynomial( C, 4, x(5) ) ! Second to last edge value - edge_values(N,1) = evaluation_polynomial( C, 4, x(4) ) - edge_values(N-1,2) = edge_values(N,1) + edge_val(N,1) = evaluation_polynomial( C, 4, x(4) ) + edge_val(N-1,2) = edge_val(N,1) #ifdef __DO_SAFETY_CHECKS__ - if (edge_values(N,1) /= edge_values(N,1) .or. edge_values(N,2) /= edge_values(N,2)) then + if (edge_val(N,1) /= edge_val(N,1) .or. edge_val(N,2) /= edge_val(N,2)) then write(0,*) 'NaN in explicit_edge_h4 at k=',N write(0,*) 'A=' do i = 1,4 @@ -490,7 +478,14 @@ end subroutine edge_values_explicit_h4 !------------------------------------------------------------------------------ !> Compute ih4 edge values (implicit fourth order accurate) -subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) +subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Compute edge values based on fourth-order implicit estimates. ! @@ -515,15 +510,6 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) ! boundary conditions close the system. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j ! loop indexes real :: h0, h1 ! cell widths @@ -627,18 +613,25 @@ subroutine edge_values_implicit_h4( N, h, u, edge_values, h_neglect ) call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) do i = 2,N - edge_values(i,1) = tri_x(i) - edge_values(i-1,2) = tri_x(i) + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) end do - edge_values(1,1) = tri_x(1) - edge_values(N,2) = tri_x(N+1) + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) end subroutine edge_values_implicit_h4 !------------------------------------------------------------------------------ !> Compute ih6 edge values (implicit sixth order accurate) -subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) +subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: h !< cell widths (size N) + real, dimension(:), intent(in) :: u !< cell average properties (size N) + real, dimension(:,:), intent(inout) :: edge_val !< Returned edge values, with the + !! same units as u; the second index size is 2. + real, optional, intent(in) :: h_neglect !< A negligibly small width + !! in the same units as h. ! ----------------------------------------------------------------------------- ! Sixth-order implicit estimates of edge values are based on a four-cell, ! three-edge stencil. A tridiagonal system is set up and is based on @@ -672,15 +665,6 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) ! on nonuniform meshes turned out to be intractable. ! ----------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell average properties (size N) - real, dimension(:,:), intent(inout) :: edge_values !< Returned edge values, with the - !! same units as u; the second index size is 2. - real, optional, intent(in) :: h_neglect !< A negligibly small width - !! in the same units as h. - ! Local variables integer :: i, j, k ! loop indexes real :: h0, h1, h2, h3 ! cell widths @@ -1124,11 +1108,11 @@ subroutine edge_values_implicit_h6( N, h, u, edge_values, h_neglect ) call solve_tridiagonal_system( tri_l, tri_d, tri_u, tri_b, tri_x, N+1 ) do i = 2,N - edge_values(i,1) = tri_x(i) - edge_values(i-1,2) = tri_x(i) + edge_val(i,1) = tri_x(i) + edge_val(i-1,2) = tri_x(i) end do - edge_values(1,1) = tri_x(1) - edge_values(N,2) = tri_x(N+1) + edge_val(1,1) = tri_x(1) + edge_val(N,2) = tri_x(N+1) end subroutine edge_values_implicit_h6 diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 6858e0cded..d9d2a19228 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -18,8 +18,7 @@ module regrid_interp implicit none ; private -type, public :: interp_CS_type - private +type, public :: interp_CS_type ; private !> The following parameter is only relevant when used with the target !! interface densities regridding scheme. It indicates which interpolation @@ -476,7 +475,9 @@ end function get_polynomial_coordinate !> Numeric value of interpolation_scheme corresponding to scheme name integer function interpolation_scheme(interp_scheme) - character(len=*), intent(in) :: interp_scheme !< Name of interpolation scheme + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" select case ( uppercase(trim(interp_scheme)) ) case ("P1M_H2"); interpolation_scheme = INTERPOLATION_P1M_H2 @@ -494,18 +495,23 @@ integer function interpolation_scheme(interp_scheme) end select end function interpolation_scheme +!> Store the interpolation_scheme value in the interp_CS based on the input string. subroutine set_interp_scheme(CS, interp_scheme) - type(interp_CS_type), intent(inout) :: CS - character(len=*), intent(in) :: interp_scheme + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" CS%interpolation_scheme = interpolation_scheme(interp_scheme) end subroutine set_interp_scheme -subroutine set_interp_extrap(CS, extrapolation) - type(interp_CS_type), intent(inout) :: CS - logical, intent(in) :: extrapolation +!> Store the boundary_extrapolation value in the interp_CS +subroutine set_interp_extrap(CS, extrap) + type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp + logical, intent(in) :: extrap !< Indicate whether high-order boundary + !! extrapolation should be used in boundary cells - CS%boundary_extrapolation = extrapolation + CS%boundary_extrapolation = extrap end subroutine set_interp_extrap end module regrid_interp diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index b9e775b1ce..7e44039831 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -25,21 +25,18 @@ module regrid_solvers contains ! ----------------------------------------------------------------------------- -! Solve the linear system AX = B -! ----------------------------------------------------------------------------- +!> Solve the linear system AX = B by Gaussian elimination subroutine solve_linear_system( A, B, X, system_size ) + real, dimension(:,:), intent(inout) :: A !< The matrix being inverted + real, dimension(:), intent(inout) :: B !< system right-hand side + real, dimension(:), intent(inout) :: X !< solution vector + integer, intent(in) :: system_size !< The size of the system ! ----------------------------------------------------------------------------- ! This routine uses Gauss's algorithm to transform the system's original ! matrix into an upper triangular matrix. Back substitution yields the answer. ! The matrix A must be square and its size must be that of the vectors B and X. ! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:,:), intent(inout) :: A - real, dimension(:), intent(inout) :: B - real, dimension(:), intent(inout) :: X - integer :: system_size - ! Local variables integer :: i, j, k real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed @@ -59,9 +56,9 @@ subroutine solve_linear_system( A, B, X, system_size ) ! entries of column i in rows below row i. Once a valid ! pivot is found (say in row k), rows i and k are swaped. k = i - do while ( ( .NOT. found_pivot ) .AND. ( k .LE. system_size ) ) + do while ( ( .NOT. found_pivot ) .AND. ( k <= system_size ) ) - if ( abs( A(k,i) ) .GT. eps ) then ! a valid pivot is found + if ( abs( A(k,i) ) > eps ) then ! a valid pivot is found found_pivot = .true. else ! Go to the next row to see ! if there is a valid pivot there @@ -79,7 +76,7 @@ subroutine solve_linear_system( A, B, X, system_size ) ! If the pivot is in a row that is different than row i, that is if ! k is different than i, we need to swap those two rows - if ( k .NE. i ) then + if ( k /= i ) then do j = 1,system_size swap_a = A(i,j) A(i,j) = A(k,j) @@ -127,18 +124,18 @@ end subroutine solve_linear_system ! ----------------------------------------------------------------------------- -! Solve the tridiagonal system AX = B -! ----------------------------------------------------------------------------- +!> Solve the tridiagonal system AX = B subroutine solve_tridiagonal_system( Al, Ad, Au, B, X, system_size ) + real, dimension(:), intent(inout) :: Ad !< Maxtix center diagonal + real, dimension(:), intent(inout) :: Al !< Matrix lower diagonal + real, dimension(:), intent(inout) :: Au !< Matrix upper diagonal + real, dimension(:), intent(inout) :: B !< system right-hand side + real, dimension(:), intent(inout) :: X !< solution vector + integer, intent(in) :: system_size !< The size of the system ! ----------------------------------------------------------------------------- ! This routine uses Thomas's algorithm to solve the tridiagonal system AX = B. ! (A is made up of lower, middle and upper diagonals) ! ----------------------------------------------------------------------------- - ! Arguments - real, dimension(:), intent(inout) :: Al, Ad, Au ! lo., mid. and up. diagonals - real, dimension(:), intent(inout) :: B ! system right-hand side - real, dimension(:), intent(inout) :: X ! solution vector - integer, intent(in) :: system_size ! Local variables integer :: k ! Loop index diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a43a252e0a..9fca715e42 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1099,7 +1099,7 @@ subroutine step_MOM_thermo(CS, G, GV, u, v, h, tv, fluxes, dtdia, & type(time_type), intent(in) :: Time_end_thermo !< End of averaging interval for thermo diags logical, intent(in) :: update_BBL !< If true, calculate the bottom boundary layer properties. type(wave_parameters_CS), & - optional, pointer :: Waves !< Container for wave related parameters; + optional, pointer :: Waves !< Container for wave related parameters !! the fields in Waves are intent in here. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. @@ -1308,7 +1308,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call enable_averaging(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval - if(accumulated_time==0) then + if (accumulated_time==0) then first_iter = .true. else ! This is probably unnecessary but is used to guard against unwanted behavior first_iter = .false. @@ -1323,17 +1323,17 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Increment the amount of time elapsed since last read and check if it's time to roll around accumulated_time = mod(accumulated_time + int(time_interval), dt_offline) - if(accumulated_time==0) then + if (accumulated_time==0) then last_iter = .true. else last_iter = .false. endif - if(CS%use_ALE_algorithm) then + if (CS%use_ALE_algorithm) then ! If this is the first iteration in the offline timestep, then we need to read in fields and ! perform the main advection. if (first_iter) then - if(is_root_pe()) print *, "Reading in new offline fields" + if (is_root_pe()) print *, "Reading in new offline fields" ! Read in new transport and other fields ! call update_transport_from_files(G, GV, CS%offline_CSp, h_end, eatr, ebtr, uhtr, vhtr, & ! CS%tv%T, CS%tv%S, fluxes, CS%use_ALE_algorithm) @@ -1368,7 +1368,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif ! Last thing that needs to be done is the final ALE remapping - if(last_iter) then + if (last_iter) then if (CS%diabatic_first) then call offline_advection_ale(fluxes, Time_start, time_interval, CS%offline_CSp, id_clock_ALE, & CS%h, uhtr, vhtr, converged=adv_converged) @@ -1387,7 +1387,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS endif endif - if(is_root_pe()) print *, "Last iteration of offline interval" + if (is_root_pe()) print *, "Last iteration of offline interval" ! Apply freshwater fluxes out of the ocean call offline_fw_fluxes_out_ocean(G, GV, CS%offline_CSp, fluxes, CS%h) @@ -1408,7 +1408,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if(time_interval .NE. dt_offline) then + if (time_interval /= dt_offline) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif @@ -2611,7 +2611,7 @@ end subroutine adjust_ssh_for_p_atm subroutine extract_surface_state(CS, sfc_state) type(MOM_control_struct), pointer :: CS !< Master MOM control structure type(surface), intent(inout) :: sfc_state !< transparent ocean surface state - !! structure shared with the calling routine; + !! structure shared with the calling routine !! data in this structure is intent out. ! local diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 4019752728..9d01f108d1 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -860,7 +860,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) ! Calculate KE (Kinetic energy for use in the -grad(KE) acceleration term). - if (CS%KE_Scheme.eq.KE_ARAKAWA) then + if (CS%KE_Scheme == KE_ARAKAWA) then ! The following calculation of Kinetic energy includes the metric terms ! identified in Arakawa & Lamb 1982 as important for KE conservation. It ! also includes the possibility of partially-blocked tracer cell faces. @@ -871,7 +871,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) +G%areaCv(i,J-1)*(v(i,J-1,k)*v(i,J-1,k)) ) & )*0.25*G%IareaT(i,j) enddo ; enddo - elseif (CS%KE_Scheme.eq.KE_SIMPLE_GUDONOV) then + elseif (CS%KE_Scheme == KE_SIMPLE_GUDONOV) then ! The following discretization of KE is based on the one-dimensinal Gudonov ! scheme which does not take into account any geometric factors do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -881,7 +881,7 @@ subroutine gradKE(u, v, h, KE, KEx, KEy, k, OBC, G, CS) vm = 0.5*( v(i, J ,k) - ABS( v(i, J ,k) ) ) ; vm2 = vm*vm KE(i,j) = ( max(up2,um2) + max(vp2,vm2) ) *0.5 enddo ; enddo - elseif (CS%KE_Scheme.eq.KE_GUDONOV) then + elseif (CS%KE_Scheme == KE_GUDONOV) then ! The following discretization of KE is based on the one-dimensinal Gudonov ! scheme but has been adapted to take horizontal grid factors into account do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_analytic_FV.F90 b/src/core/MOM_PressureForce_analytic_FV.F90 index 3f2ae7528a..672651ffb0 100644 --- a/src/core/MOM_PressureForce_analytic_FV.F90 +++ b/src/core/MOM_PressureForce_analytic_FV.F90 @@ -240,9 +240,9 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm ! of freedeom needed to know the linear profile). if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call pressure_gradient_plm (ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call pressure_gradient_plm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) elseif ( CS%Recon_Scheme == 2) then - call pressure_gradient_ppm (ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) + call pressure_gradient_ppm(ALE_CSp, S_t, S_b, T_t, T_b, G, GV, tv, h, CS%boundary_extrap) endif endif @@ -253,7 +253,7 @@ subroutine PressureForce_AFV_nonBouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm if (use_EOS) then if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_spec_vol_dp_generic_plm ( T_t(:,:,k), T_b(:,:,k), & + call int_spec_vol_dp_generic_plm( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), p(:,:,K), p(:,:,K+1), & alpha_ref, dp_neglect, p(:,:,nz+1), G%HI, & tv%eqn_of_state, dza(:,:,k), intp_dza(:,:,k), & @@ -665,14 +665,14 @@ subroutine PressureForce_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_atm, p ! where the layers are located. if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm ( T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, & dz_neglect, G%bathyT, G%HI, G%HI, & tv%eqn_of_state, dpa, intz_dpa, intx_dpa, inty_dpa, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, & G%HI, G%HI, tv%eqn_of_state, dpa, intz_dpa, & diff --git a/src/core/MOM_PressureForce_blocked_AFV.F90 b/src/core/MOM_PressureForce_blocked_AFV.F90 index 563972fcc5..1cad7d38c9 100644 --- a/src/core/MOM_PressureForce_blocked_AFV.F90 +++ b/src/core/MOM_PressureForce_blocked_AFV.F90 @@ -663,14 +663,14 @@ subroutine PressureForce_blk_AFV_Bouss(h, tv, PFu, PFv, G, GV, CS, ALE_CSp, p_at ! where the layers are located. if ( use_ALE ) then if ( CS%Recon_Scheme == 1 ) then - call int_density_dz_generic_plm ( T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_plm( T_t(:,:,k), T_b(:,:,k), & S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, & dz_neglect, G%bathyT, G%HI, G%Block(n), & tv%eqn_of_state, dpa_bk, intz_dpa_bk, intx_dpa_bk, inty_dpa_bk, & useMassWghtInterp = CS%useMassWghtInterp) elseif ( CS%Recon_Scheme == 2 ) then - call int_density_dz_generic_ppm ( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & + call int_density_dz_generic_ppm( tv%T(:,:,k), T_t(:,:,k), T_b(:,:,k), & tv%S(:,:,k), S_t(:,:,k), S_b(:,:,k), e(:,:,K), e(:,:,K+1), & rho_ref, CS%Rho0, GV%g_Earth, & G%HI, G%Block(n), tv%eqn_of_state, dpa_bk, intz_dpa_bk, & diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index c47b16989e..8f7685b605 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -143,7 +143,7 @@ end subroutine MOM_thermo_chksum subroutine MOM_surface_chksum(mesg, sfc, G, haloshift, symmetric) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(surface), intent(inout) :: sfc !< transparent ocean surface state - !! structure shared with the calling routine; + !! structure shared with the calling routine !! data in this structure is intent out. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 6a65c7e844..7f590f6d5e 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -511,20 +511,20 @@ subroutine extractFluxes1d(G, GV, fluxes, optics, nsw, j, dt, ! evap > 0 means condensating water is added into ocean. ! evap < 0 means evaporation of water from the ocean, in ! which case heat_content_evap is computed in MOM_diabatic_driver.F90 - if(fluxes%evap(i,j) < 0.0) then + if (fluxes%evap(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%evap(i,j) - ! if(associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA + ! if (associated(fluxes%heat_content_cond)) fluxes%heat_content_cond(i,j) = 0.0 !??? --AJA endif ! lprec < 0 means sea ice formation taking water from the ocean. ! smg: we should split the ice melt/formation from the lprec - if(fluxes%lprec(i,j) < 0.0) then + if (fluxes%lprec(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%lprec(i,j) endif ! vprec < 0 means virtual evaporation arising from surface salinity restoring, ! in which case heat_content_vprec is computed in MOM_diabatic_driver.F90. - if(fluxes%vprec(i,j) < 0.0) then + if (fluxes%vprec(i,j) < 0.0) then netMassOut(i) = netMassOut(i) + fluxes%vprec(i,j) endif netMassOut(i) = dt * scale * netMassOut(i) @@ -2074,48 +2074,48 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%vprec)) res(i,j) = res(i,j)+fluxes%vprec(i,j) enddo ; enddo call post_data(handles%id_prcme, res, diag) - if(handles%id_total_prcme > 0) then + if (handles%id_total_prcme > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_prcme, total_transport, diag) endif - if(handles%id_prcme_ga > 0) then + if (handles%id_prcme_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_prcme_ga, ave_flux, diag) endif endif - if(handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then + if (handles%id_net_massout > 0 .or. handles%id_total_net_massout > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) - if(fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) - if(fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (fluxes%lprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (fluxes%vprec(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (fluxes%evap(i,j) < 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) enddo ; enddo call post_data(handles%id_net_massout, res, diag) - if(handles%id_total_net_massout > 0) then + if (handles%id_total_net_massout > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massout, total_transport, diag) endif endif - if(handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) + if (handles%id_massout_flux > 0) call post_data(handles%id_massout_flux,fluxes%netMassOut,diag) - if(handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then + if (handles%id_net_massin > 0 .or. handles%id_total_net_massin > 0) then do j=js,je ; do i=is,ie res(i,j) = fluxes%fprec(i,j) + fluxes%lrunoff(i,j) + fluxes%frunoff(i,j) - if(fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) - if(fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) + if (fluxes%lprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%lprec(i,j) + if (fluxes%vprec(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%vprec(i,j) ! fluxes%cond is not needed because it is derived from %evap > 0 - if(fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) + if (fluxes%evap(i,j) > 0.0) res(i,j) = res(i,j) + fluxes%evap(i,j) enddo ; enddo call post_data(handles%id_net_massin, res, diag) - if(handles%id_total_net_massin > 0) then + if (handles%id_total_net_massin > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_massin, total_transport, diag) endif endif - if(handles%id_massin_flux > 0) call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) + if (handles%id_massin_flux > 0) call post_data(handles%id_massin_flux,fluxes%netMassIn,diag) if ((handles%id_evap > 0) .and. associated(fluxes%evap)) & call post_data(handles%id_evap, fluxes%evap, diag) @@ -2263,11 +2263,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (associated(fluxes%SW)) res(i,j) = res(i,j) + fluxes%SW(i,j) enddo ; enddo call post_data(handles%id_net_heat_coupler, res, diag) - if(handles%id_total_net_heat_coupler > 0) then + if (handles%id_total_net_heat_coupler > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_coupler, total_transport, diag) endif - if(handles%id_net_heat_coupler_ga > 0) then + if (handles%id_net_heat_coupler_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_net_heat_coupler_ga, ave_flux, diag) endif @@ -2297,11 +2297,11 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) enddo ; enddo call post_data(handles%id_net_heat_surface, res, diag) - if(handles%id_total_net_heat_surface > 0) then + if (handles%id_total_net_heat_surface > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_net_heat_surface, total_transport, diag) endif - if(handles%id_net_heat_surface_ga > 0) then + if (handles%id_net_heat_surface_ga > 0) then ave_flux = global_area_mean(res,G) call post_data(handles%id_net_heat_surface_ga, ave_flux, diag) endif @@ -2323,7 +2323,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) ! endif enddo ; enddo call post_data(handles%id_heat_content_surfwater, res, diag) - if(handles%id_total_heat_content_surfwater > 0) then + if (handles%id_total_heat_content_surfwater > 0) then total_transport = global_area_integral(res,G) call post_data(handles%id_total_heat_content_surfwater, total_transport, diag) endif @@ -2333,8 +2333,8 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_hfrunoffds > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) - if(associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) + if (associated(fluxes%heat_content_lrunoff)) res(i,j) = res(i,j) + fluxes%heat_content_lrunoff(i,j) + if (associated(fluxes%heat_content_frunoff)) res(i,j) = res(i,j) + fluxes%heat_content_frunoff(i,j) enddo ; enddo call post_data(handles%id_hfrunoffds, res, diag) endif @@ -2343,9 +2343,9 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if (handles%id_hfrainds > 0) then do j=js,je ; do i=is,ie res(i,j) = 0.0 - if(associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) - if(associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) - if(associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) + if (associated(fluxes%heat_content_lprec)) res(i,j) = res(i,j) + fluxes%heat_content_lprec(i,j) + if (associated(fluxes%heat_content_fprec)) res(i,j) = res(i,j) + fluxes%heat_content_fprec(i,j) + if (associated(fluxes%heat_content_cond)) res(i,j) = res(i,j) + fluxes%heat_content_cond(i,j) enddo ; enddo call post_data(handles%id_hfrainds, res, diag) endif @@ -2439,7 +2439,7 @@ subroutine forcing_diagnostics(fluxes, sfc_state, dt, G, diag, handles) if ((handles%id_lat_frunoff > 0) .and. associated(fluxes%latent_frunoff_diag)) then call post_data(handles%id_lat_frunoff, fluxes%latent_frunoff_diag, diag) endif - if(handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then + if (handles%id_total_lat_frunoff > 0 .and. associated(fluxes%latent_frunoff_diag)) then total_transport = global_area_integral(fluxes%latent_frunoff_diag,G) call post_data(handles%id_total_lat_frunoff, total_transport, diag) endif diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 9f5d79ef4e..91f9f6546b 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -303,7 +303,7 @@ subroutine open_boundary_config(G, param_file, OBC) call get_param(param_file, mdl, "NK", OBC%ke, & "The number of model layers", default=0, do_not_log=.true.) - if (config1 .ne. "none") OBC%user_BCs_set_globally = .true. + if (config1 /= "none") OBC%user_BCs_set_globally = .true. if (OBC%number_of_segments > 0) then call get_param(param_file, mdl, "OBC_ZERO_VORTICITY", OBC%zero_vorticity, & diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index 4301368de9..2e9c80470a 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -96,12 +96,12 @@ end subroutine MOM_debugging_init subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -125,12 +125,12 @@ end subroutine check_redundant_vC3d subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -199,10 +199,10 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vC2d subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -224,10 +224,10 @@ end subroutine check_redundant_sB3d subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -284,12 +284,12 @@ end subroutine check_redundant_sB2d subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -313,12 +313,12 @@ end subroutine check_redundant_vB3d subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -388,10 +388,10 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vB2d subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -413,10 +413,10 @@ end subroutine check_redundant_sT3d subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: array - integer, optional, intent(in) :: is, ie, js, je + real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency ! Arguments: array - The array being checked. ! (in) mesg - A message indicating what is being checked. ! (in) G - The ocean's grid structure. @@ -459,12 +459,12 @@ end subroutine check_redundant_sT2d subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. @@ -488,12 +488,12 @@ end subroutine check_redundant_vT3d subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & direction) - character(len=*), intent(in) :: mesg + character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp - integer, optional, intent(in) :: is, ie, js, je - integer, optional, intent(in) :: direction + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The u-component of the vector to be checked for consistency + integer, optional, intent(in) :: is, ie, js, je !< The range of indices to check for consistency + integer, optional, intent(in) :: direction !< the direction flag to be passed to pass_vector ! Arguments: u_comp - The u-component of the vector being checked. ! (in) v_comp - The v-component of the vector being checked. ! (in) mesg - A message indicating what is being checked. diff --git a/src/diagnostics/MOM_diag_to_Z.F90 b/src/diagnostics/MOM_diag_to_Z.F90 index 5dd78e8eee..4efed0628f 100644 --- a/src/diagnostics/MOM_diag_to_Z.F90 +++ b/src/diagnostics/MOM_diag_to_Z.F90 @@ -106,7 +106,7 @@ function global_z_mean(var,G,CS,tracer) real, dimension(CS%nk_zspace) :: global_z_mean, scalarij, weightij real, dimension(CS%nk_zspace) :: global_temp_scalar, global_weight_scalar integer :: i, j, k, is, ie, js, je, nz, tracer - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec nz = CS%nk_zspace ! Initialize local arrays @@ -1153,7 +1153,7 @@ subroutine get_Z_depths(depth_file, int_depth_name, int_depth, cell_depth_name, nk_out = -1 - status = NF90_OPEN(depth_file, NF90_NOWRITE, ncid); + status = NF90_OPEN(depth_file, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,"MOM_diag_to_Z get_Z_depths: "//& " Difficulties opening "//trim(depth_file)//" - "//& @@ -1302,7 +1302,7 @@ function ocean_register_diag_with_z(tr_ptr, vardesc_tr, G, Time, CS) ! register the layer tracer ocean_register_diag_with_z = ocean_register_diag(vardesc_tr, G, CS%diag, Time) - ! copy layer tracer variable descriptor to a z-tracer descriptor; + ! copy layer tracer variable descriptor to a z-tracer descriptor ! change the name and layer information. vardesc_z = vardesc_tr call modify_vardesc(vardesc_z, z_grid="z", caller="ocean_register_diag_with_z") diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 6e557426c7..7add057e0e 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -344,7 +344,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & endif else ! thkcello = dp/(rho*g) for non-Boussinesq do j=js,je - if(associated(p_surf)) then ! Pressure loading at top of surface layer (Pa) + if (associated(p_surf)) then ! Pressure loading at top of surface layer (Pa) do i=is,ie pressure_1d(i) = p_surf(i,j) enddo @@ -932,8 +932,8 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, CS) if (CS%id_KE > 0) call post_data(CS%id_KE, CS%KE, CS%diag) endif - if(.not.G%symmetric) then - if(associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_CorAdv) .OR. & + if (.not.G%symmetric) then + if (associated(CS%dKE_dt) .OR. associated(CS%PE_to_KE) .OR. associated(CS%KE_CorAdv) .OR. & associated(CS%KE_adv) .OR. associated(CS%KE_visc) .OR. associated(CS%KE_horvisc).OR. & associated(CS%KE_dia) ) then call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index a036509437..4db4d30c18 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -136,7 +136,7 @@ module MOM_sum_output ! Start_time is set in MOM_initialization.F90 integer, pointer :: ntrunc ! The number of times the velocity has been ! truncated since the last call to write_energy. - real :: max_Energy ! The maximum permitted energy per unit mass; + real :: max_Energy ! The maximum permitted energy per unit mass ! If there is more energy than this, the model ! should stop, in m2 s-2. integer :: maxtrunc ! The number of truncations per energy save @@ -223,7 +223,7 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & "The maximum velocity allowed before the velocity \n"//& "components are truncated.", units="m s-1", default=3.0e8) CS%max_Energy = 10.0 * maxvel**2 - call log_param (param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) + call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & @@ -232,7 +232,7 @@ subroutine MOM_sum_output_init(G, param_file, directory, ntrnc, & !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then energyfile = trim(energyfile) //'.'//trim(filename_appendix) end if @@ -881,7 +881,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, CS, tracer_CSp, OBC, dt_forc write(*,'(" Total ",a,": ",ES24.16,X,a)') & trim(Tr_names(m)), Tr_stocks(m), trim(Tr_units(m)) - if(Tr_minmax_got(m)) then + if (Tr_minmax_got(m)) then write(*,'(64X,"Global Min:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & Tr_min(m),Tr_min_x(m),Tr_min_y(m),Tr_min_z(m) write(*,'(64X,"Global Max:",ES24.16,X,"at: (", f7.2,","f7.2,","f8.2,")" )') & @@ -1328,7 +1328,7 @@ subroutine read_depth_list(G, CS, filename) mdl = "MOM_sum_output read_depth_list:" - status = NF90_OPEN(filename, NF90_NOWRITE, ncid); + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(FATAL,mdl//" Difficulties opening "//trim(filename)// & " - "//trim(NF90_STRERROR(status))) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 6b0c90e55e..ec4a78fc7b 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -849,8 +849,8 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) enddo ! print resutls (for debugging only) - !if(ig .eq. 83 .and. jg .eq. 2) then - ! if(nmodes>1)then + !if (ig == 83 .and. jg == 2) then + ! if (nmodes>1)then ! print *, "Results after finding first mode:" ! print *, "first guess at lam_1=", 1./speed2_tot ! print *, "final guess at lam_1=", lam_1 @@ -878,7 +878,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! set number of intervals within search range numint = nint((lamMax - lamMin)/lamInc) - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then ! print *, 'Looking for other eigenvalues at', ig, jg ! print *, 'Wave_speed: lamMin=', lamMin ! print *, 'Wave_speed: cnMax=', 1/sqrt(lamMin) @@ -899,7 +899,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) xl = xr - lamInc call tridiag_det(a_diag(1:nrows),b_diag(1:nrows),c_diag(1:nrows), & nrows,xr,det_r,ddet_r) - !if(ig .eq. 83 .and. jg .eq. 2) then + !if (ig == 83 .and. jg == 2) then ! print *, "Move interval" ! print *, "iint=",iint ! print *, "@ xr=",xr @@ -911,7 +911,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) nrootsfound = nrootsfound + 1 xbl(nrootsfound) = xl xbr(nrootsfound) = xr - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then ! print *, "Root located without subdivision!" ! print *, "between xbl=",xl,"and xbr=",xr !endif @@ -939,7 +939,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) nrootsfound = nrootsfound + 1 xbl(nrootsfound) = xl_sub xbr(nrootsfound) = xr - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then ! print *, "Root located after subdiving",sub_it," times!" ! print *, "between xbl=",xl_sub,"and xbr=",xr !endif @@ -954,7 +954,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) call MOM_error(WARNING, "wave_speed: root not found "// & " after sub_it_max subdivisions of original"// & " interval.") - !if(ig .eq. 144 .and. jg .eq. 5) then + !if (ig == 144 .and. jg == 5) then !print *, "xbl=",xbl !print *, "xbr=",xbr !print *, "Wave_speed: kc=",kc @@ -979,7 +979,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! oops, lamMax not large enough - could add code to increase (BDM) ! set unfound modes to zero for now (BDM) cn(i,j,nrootsfound+2:nmodes) = 0.0 - !if(ig .eq. 83 .and. jg .eq. 2) then + !if (ig == 83 .and. jg == 2) then ! call MOM_error(WARNING, "wave_speed: not all modes found "// & ! " within search range: increase numint.") ! print *, "Increase lamMax at ig=",ig," jg=",jg @@ -1030,7 +1030,7 @@ subroutine wave_speeds(h, tv, G, GV, nmodes, cn, CS, full_halos) ! ----- Spot check - comment out later (BDM) ---------- !ig = G%idg_offset + i !jg = G%jdg_offset + j - !if (ig .eq. 83 .and. jg .eq. 2) then + !if (ig == 83 .and. jg == 2) then !! print *, "nmodes=",nmodes ! print *, "lam_1=",lam_1 ! print *, "lamMin=",lamMin @@ -1065,9 +1065,9 @@ subroutine tridiag_det(a,b,c,nrows,lam,det_out,ddet_out) real :: I_rescale ! inverse of rescale integer :: n ! row (layer interface) index - if (size(b) .ne. nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") - if (size(a) .ne. nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") - if (size(c) .ne. nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") + if (size(b) /= nrows) call MOM_error(WARNING, "Diagonal b must be same length as nrows.") + if (size(a) /= nrows) call MOM_error(WARNING, "Diagonal a must be same length as nrows.") + if (size(c) /= nrows) call MOM_error(WARNING, "Diagonal c must be same length as nrows.") I_rescale = 1.0/rescale diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 1db88cb804..88f5bc06d5 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -272,10 +272,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! From this point, we can work on individual columns without causing memory ! to have page faults. - do i=is,ie ; if(cn(i,j)>0.0)then + do i=is,ie ; if (cn(i,j)>0.0)then !----for debugging, remove later---- ig = i + G%idg_offset ; jg = j + G%jdg_offset - !if(ig .eq. CS%int_tide_source_x .and. jg .eq. CS%int_tide_source_y) then + !if (ig == CS%int_tide_source_x .and. jg == CS%int_tide_source_y) then !----------------------------------- if (G%mask2dT(i,j) > 0.5) then @@ -423,10 +423,10 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) a_diag(row) = gprime(K)*(-Igu(K)) b_diag(row) = gprime(K)*(Igu(K)+Igl(K)) - lam_z(row) c_diag(row) = gprime(K)*(-Igl(K)) - if(isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif - if(isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif - if(isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif - if(isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif + if (isnan(lam_z(row)))then ; print *, "Wave_structure: lam_z(row) is NAN" ; endif + if (isnan(a_diag(row)))then ; print *, "Wave_structure: a(k) is NAN" ; endif + if (isnan(b_diag(row)))then ; print *, "Wave_structure: b(k) is NAN" ; endif + if (isnan(c_diag(row)))then ; print *, "Wave_structure: c(k) is NAN" ; endif enddo ! Populate top row of tridiagonal matrix K=2 ; row = K-1 @@ -457,9 +457,9 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) ! Check to see if solver worked ig_stop = 0 ; jg_stop = 0 - if(isnan(sum(w_strct(1:kc+1))))then + if (isnan(sum(w_strct(1:kc+1))))then print *, "Wave_structure: w_strct has a NAN at ig=", ig, ", jg=", jg - if(iG%iec .or. jG%jec)then + if (iG%iec .or. jG%jec)then print *, "This is occuring at a halo point." endif ig_stop = ig ; jg_stop = jg @@ -534,7 +534,7 @@ subroutine wave_structure(h, tv, G, GV, cn, ModeNum, freq, CS, En, full_halos) CS%num_intfaces(i,j) = nzm !----for debugging; delete later---- - !if(ig .eq. ig_stop .and. jg .eq. jg_stop) then + !if (ig == ig_stop .and. jg == jg_stop) then !print *, 'cn(ig,jg)=', cn(i,j) !print *, "e_guess=", e_guess(1:kc-1) !print *, "|e_guess|=", sqrt(sum(e_guess(1:kc-1)**2)) @@ -673,14 +673,14 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! Check results - delete later !do j=1,nrow ; do i=1,nrow - ! if(i==j)then ; A_check(i,j) = b(i) - ! elseif(i==j+1)then ; A_check(i,j) = a(i) - ! elseif(i==j-1)then ; A_check(i,j) = c(i) + ! if (i==j)then ; A_check(i,j) = b(i) + ! elseif (i==j+1)then ; A_check(i,j) = a(i) + ! elseif (i==j-1)then ; A_check(i,j) = c(i) ! endif !enddo ; enddo !print *, 'A(2,1),A(2,2),A(1,2)=', A_check(2,1), A_check(2,2), A_check(1,2) !y_check = matmul(A_check,x) - !if(all(y_check .ne. y))then + !if (all(y_check /= y))then ! print *, "tridiag_solver: Uh oh, something's not right!" ! print *, "y=", y ! print *, "y_check=", y_check @@ -713,12 +713,12 @@ subroutine tridiag_solver(a,b,c,h,y,method,x) ! Forward sweep do k=2,nrow-1 beta = 1/(h(k)+alpha(k-1)*Q_prime+alpha(k)) - if(isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif + if (isnan(beta))then ; print *, "Tridiag_solver: beta is NAN" ; endif q(k) = beta*alpha(k) y_prime(k) = beta*(y(k)+alpha(k-1)*y_prime(k-1)) Q_prime = beta*(h(k)+alpha(k-1)*Q_prime) enddo - if((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then + if ((h(nrow)+alpha(nrow-1)*Q_prime+alpha(nrow)) == 0.0)then call MOM_error(WARNING, "Tridiag_solver: this system is not stable; overriding beta(nrow).") beta = 1/(1e-15) ! place holder for unstable systems - delete later else diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index f504bf220b..dceed058f2 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1575,7 +1575,7 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & !rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - & ! rho_ref - rho_anom = 1000.0 + S(i,j) - rho_ref; + rho_anom = 1000.0 + S(i,j) - rho_ref dpa(i-ioff,j-joff) = G_e*dz*rho_anom ! Use a Bode's-rule-like fifth-order accurate estimate of @@ -1680,10 +1680,10 @@ subroutine int_density_dz_generic_ppm (T, T_t, T_b, S, S_t, S_b, & S_node(9) = 0.5 * ( S_node(6) + S_node(8) ) S_node(7) = 0.5 * ( S_node(3) + S_node(4) ) - call calculate_density ( T_node, S_node, p_node, r_node, 1, 9, EOS ) + call calculate_density( T_node, S_node, p_node, r_node, 1, 9, EOS ) r_node = r_node - rho_ref - call compute_integral_quadratic ( x, y, r_node, intx_dpa(i-ioff,j-joff) ) + call compute_integral_quadratic( x, y, r_node, intx_dpa(i-ioff,j-joff) ) intx_dpa(i-ioff,j-joff) = intx_dpa(i-ioff,j-joff) * G_e @@ -1755,8 +1755,8 @@ subroutine compute_integral_quadratic ( x, y, f, integral ) do k = 1,9 ! Evaluate shape functions and gradients for isomorphism - call evaluate_shape_bilinear ( xi(k), eta(k), phiiso, & - dphiisodxi, dphiisodeta ) + call evaluate_shape_bilinear( xi(k), eta(k), phiiso, & + dphiisodxi, dphiisodeta ) ! Determine gradient of global coordinate at integration point dxdxi = 0.0 @@ -1775,7 +1775,7 @@ subroutine compute_integral_quadratic ( x, y, f, integral ) jacobian_k = dxdxi*dydeta - dydxi*dxdeta ! Evaluate shape functions for interpolation - call evaluate_shape_quadratic ( xi(k), eta(k), phi, dphidxi, dphideta ) + call evaluate_shape_quadratic( xi(k), eta(k), phi, dphidxi, dphideta ) ! Evaluate function at integration point f_k = 0.0 @@ -2332,10 +2332,10 @@ subroutine convert_temp_salt_for_TEOS10(T, S, press, G, kd, mask_z, EOS) if (.not.associated(EOS)) call MOM_error(FATAL, & "convert_temp_salt_to_TEOS10 called with an unassociated EOS_type EOS.") - if ((EOS%form_of_EOS .ne. EOS_TEOS10) .and. (EOS%form_of_EOS .ne. EOS_NEMO)) return + if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return do k=1,kd ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (mask_z(i,j,k) .ge. 1.0) then + if (mask_z(i,j,k) >= 1.0) then S(i,j,k) = gsw_sr_from_sp(S(i,j,k)) ! p=press(k)/10000. !convert pascal to dbar ! S(i,j,k) = gsw_sa_from_sp(S(i,j,k),p,G%geoLonT(i,j),G%geoLatT(i,j)) diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index f0811422d5..ce940ca26f 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -195,7 +195,7 @@ subroutine calculate_density_derivs_scalar_teos10(T, S, pressure, drho_dT, drho_ zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if(S.lt.-1.0e-10) return !Can we assume safely that this is a missing value? + if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) end subroutine calculate_density_derivs_scalar_teos10 @@ -257,7 +257,7 @@ subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if(S.lt.-1.0e-10) return !Can we assume safely that this is a missing value? + if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index aef6b60ecb..ddc0e215da 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -205,7 +205,7 @@ subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) zs = S(j) zp = pres(j)* Pa2db !Convert pressure from Pascal to decibar - if(S(j).lt.-1.0e-10) cycle !Can we assume safely that this is a missing value? + if (S(j) < -1.0e-10) cycle !Can we assume safely that this is a missing value? T_Fr(j) = gsw_ct_freezing_exact(zs,zp,saturation_fraction) enddo diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index 01678dce41..fd880f6656 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -189,10 +189,10 @@ subroutine chksum_h_2d(array, mesg, HI, haloshift, omit_corners, scale) contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj; do i=HI%isc+di,HI%iec+di @@ -204,9 +204,9 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array - character(len=*), intent(in) :: mesg + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message integer :: i, j, n real :: aMean, aMin, aMax @@ -375,10 +375,10 @@ subroutine chksum_B_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -391,10 +391,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, n, IsB, JsB real :: aMean, aMin, aMax @@ -562,10 +563,10 @@ subroutine chksum_u_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -578,10 +579,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, n, IsB real :: aMean, aMin, aMax @@ -706,10 +708,10 @@ subroutine chksum_v_2d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -722,10 +724,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, n, JsB real :: aMean, aMin, aMax @@ -832,10 +835,10 @@ subroutine chksum_h_3d(array, mesg, HI, haloshift, omit_corners, scale) contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di @@ -847,9 +850,9 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array - character(len=*), intent(in) :: mesg + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message integer :: i, j, k, n real :: aMean, aMin, aMax @@ -973,10 +976,10 @@ subroutine chksum_B_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -989,10 +992,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, k, n, IsB, JsB real :: aMean, aMin, aMax @@ -1117,10 +1121,10 @@ subroutine chksum_u_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1133,10 +1137,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, k, n, IsB real :: aMean, aMin, aMax @@ -1334,10 +1339,10 @@ subroutine chksum_v_3d(array, mesg, HI, haloshift, symmetric, omit_corners, scal contains integer function subchk(array, HI, di, dj, scale) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array - integer, intent(in) :: di, dj - real, intent(in) :: scale + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + integer, intent(in) :: di, dj !< i- and j- direction array shifts for this checksum + real, intent(in) :: scale !< A scaling factor for this array. integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1350,10 +1355,11 @@ integer function subchk(array, HI, di, dj, scale) end function subchk subroutine subStats(HI, array, mesg, sym_stats) - type(hor_index_type), intent(in) :: HI - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array - character(len=*), intent(in) :: mesg - logical, intent(in) :: sym_stats + type(hor_index_type), intent(in) :: HI !< A horizontal index type + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + character(len=*), intent(in) :: mesg !< An identifying message + logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the + !! full symmetric computational domain. integer :: i, j, k, n, JsB real :: aMean, aMin, aMax @@ -1445,8 +1451,8 @@ end subroutine chksum1d !> chksum2d does a checksum of all data in a 2-d array. subroutine chksum2d(array, mesg) - real, dimension(:,:) :: array - character(len=*) :: mesg + real, dimension(:,:) :: array !< The array to be checksummed + character(len=*) :: mesg !< An identifying message integer :: xs,xe,ys,ye,i,j,sum1,bc real :: sum @@ -1473,8 +1479,8 @@ end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. subroutine chksum3d(array, mesg) - real, dimension(:,:,:) :: array - character(len=*) :: mesg + real, dimension(:,:,:) :: array !< The array to be checksummed + character(len=*) :: mesg !< An identifying message integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 real :: sum @@ -1583,63 +1589,75 @@ function is_NaN_3d(x) end function is_NaN_3d ! ===================================================================== - +!> Write a message including the checksum of the non-shifted array subroutine chk_sum_msg1(fmsg,bc0,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0 + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array if (is_root_pe()) write(0,'(A,1(A,I10,X),A)') fmsg," c=",bc0,trim(mesg) end subroutine chk_sum_msg1 ! ===================================================================== - +!> Write a message including checksums of non-shifted and diagonally shifted arrays subroutine chk_sum_msg5(fmsg,bc0,bcSW,bcSE,bcNW,bcNE,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0,bcSW,bcSE,bcNW,bcNE + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcSW,bcSE,bcNW,bcNE !< The bitcounts for 4 diagonal array shifts if (is_root_pe()) write(0,'(A,5(A,I10,1X),A)') & fmsg," c=",bc0,"sw=",bcSW,"se=",bcSE,"nw=",bcNW,"ne=",bcNE,trim(mesg) end subroutine chk_sum_msg5 ! ===================================================================== - +!> Write a message including checksums of non-shifted and laterally shifted arrays subroutine chk_sum_msg_NSEW(fmsg,bc0,bcN,bcS,bcE,bcW,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcN, bcS, bcE, bcW + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcN, bcS, bcE, bcW !< The bitcounts including 4 lateral array shifts if (is_root_pe()) write(0,'(A,5(A,I10,1X),A)') & fmsg," c=",bc0,"N=",bcN,"S=",bcS,"E=",bcE,"W=",bcW,trim(mesg) end subroutine chk_sum_msg_NSEW ! ===================================================================== - +!> Write a message including checksums of non-shifted and southward shifted arrays subroutine chk_sum_msg_S(fmsg,bc0,bcS,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcS + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcS !< The bitcount of the south-shifted array if (is_root_pe()) write(0,'(A,2(A,I10,1X),A)') & fmsg," c=",bc0,"S=",bcS,trim(mesg) end subroutine chk_sum_msg_S ! ===================================================================== - +!> Write a message including checksums of non-shifted and westward shifted arrays subroutine chk_sum_msg_W(fmsg,bc0,bcW,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0, bcW + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcW !< The bitcount of the west-shifted array if (is_root_pe()) write(0,'(A,2(A,I10,1X),A)') & fmsg," c=",bc0,"W=",bcW,trim(mesg) end subroutine chk_sum_msg_W ! ===================================================================== - +!> Write a message including checksums of non-shifted and southwestward shifted arrays subroutine chk_sum_msg2(fmsg,bc0,bcSW,mesg) - character(len=*), intent(in) :: fmsg, mesg - integer, intent(in) :: bc0,bcSW + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + integer, intent(in) :: bc0 !< The bitcount of the non-shifted array + integer, intent(in) :: bcSW !< The bitcount of the southwest-shifted array if (is_root_pe()) write(0,'(A,2(A,I9,1X),A)') & fmsg," c=",bc0,"s/w=",bcSW,trim(mesg) end subroutine chk_sum_msg2 ! ===================================================================== - +!> Write a message including the global mean, maximum and minimum of an array subroutine chk_sum_msg3(fmsg,aMean,aMin,aMax,mesg) - character(len=*), intent(in) :: fmsg, mesg - real, intent(in) :: aMean,aMin,aMax + character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble + character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller + real, intent(in) :: aMean,aMin,aMax !< The mean, minimum and maximum of the array if (is_root_pe()) write(0,'(A,3(A,ES25.16,1X),A)') & fmsg," mean=",aMean,"min=",aMin,"max=",aMax,trim(mesg) end subroutine chk_sum_msg3 @@ -1659,12 +1677,11 @@ subroutine MOM_checksums_init(param_file) end subroutine MOM_checksums_init ! ===================================================================== - +!> A wrapper for MOM_error used in the checksum code subroutine chksum_error(signal, message) - ! Wrapper for MOM_error to help place specific break points in - ! debuggers - integer, intent(in) :: signal - character(len=*), intent(in) :: message + ! Wrapper for MOM_error to help place specific break points in debuggers + integer, intent(in) :: signal !< An error severity level, such as FATAL or WARNING + character(len=*), intent(in) :: message !< An error message call MOM_error(signal, message) end subroutine chksum_error diff --git a/src/framework/MOM_coms.F90 b/src/framework/MOM_coms.F90 index d2a268a741..cae5303c96 100644 --- a/src/framework/MOM_coms.F90 +++ b/src/framework/MOM_coms.F90 @@ -116,20 +116,20 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & if (over_check) then if ((je+1-js)*(ie+1-is) < max_count_prec) then do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) enddo ; enddo call carry_overflow(ints_sum, prec_error) elseif ((ie+1-is) < max_count_prec) then do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo else do j=js,je ; do i=is,ie call increment_ints(ints_sum, real_to_ints(array(i,j), prec_error), & - prec_error); + prec_error) enddo ; enddo endif else @@ -172,7 +172,7 @@ function reproducing_sum_2d(array, isr, ier, jsr, jer, EFP_sum, reproducing, & else rsum(1) = 0.0 do j=js,je ; do i=is,ie - rsum(1) = rsum(1) + array(i,j); + rsum(1) = rsum(1) + array(i,j) enddo ; enddo call sum_across_PEs(rsum,1) sum = rsum(1) @@ -260,21 +260,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (jsz*isz < max_count_prec) then do k=1,ke do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) enddo ; enddo call carry_overflow(ints_sums(:,k), prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sums(:,k), array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sums(:,k), prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sums(:,k), & - real_to_ints(array(i,j,k), prec_error), prec_error); + real_to_ints(array(i,j,k), prec_error), prec_error) enddo ; enddo ; enddo endif if (present(err)) then @@ -318,21 +318,21 @@ function reproducing_sum_3d(array, isr, ier, jsr, jer, sums, EFP_sum, err) & if (jsz*isz < max_count_prec) then do k=1,ke do j=js,je ; do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) enddo ; enddo call carry_overflow(ints_sum, prec_error) enddo elseif (isz < max_count_prec) then do k=1,ke ; do j=js,je do i=is,ie - call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term); + call increment_ints_faster(ints_sum, array(i,j,k), max_mag_term) enddo call carry_overflow(ints_sum, prec_error) enddo ; enddo else do k=1,ke ; do j=js,je ; do i=is,ie call increment_ints(ints_sum, real_to_ints(array(i,j,k), prec_error), & - prec_error); + prec_error) enddo ; enddo ; enddo endif if (present(err)) then diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index e37e4bddff..34bde56f02 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -242,7 +242,7 @@ subroutine set_axes_info(G, GV, param_file, diag_cs, set_vertical) set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical - if(G%symmetric) then + if (G%symmetric) then id_xq = diag_axis_init('xq', G%gridLonB(G%isgB:G%iegB), G%x_axis_units, 'x', & 'q point nominal longitude', Domain2=G%Domain%mpp_domain) id_yq = diag_axis_init('yq', G%gridLatB(G%jsgB:G%jegB), G%y_axis_units, 'y', & @@ -886,7 +886,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) 'post_data_2d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif(associated(diag%axes%mask2d)) then + !elseif (associated(diag%axes%mask2d)) then ! used = send_data(diag%fms_diag_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask2d) else @@ -900,7 +900,7 @@ subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=mask) - elseif(associated(diag%axes%mask2d)) then + elseif (associated(diag%axes%mask2d)) then used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=diag%axes%mask2d) @@ -939,7 +939,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) logical :: staggered_in_x, staggered_in_y real, dimension(:,:,:), pointer :: h_diag - if(present(alt_h)) then + if (present(alt_h)) then h_diag => alt_h else h_diag => diag_cs%h @@ -1136,7 +1136,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) 'post_data_3d_low is_stat: mask size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=mask) - !elseif(associated(diag%axes%mask3d)) then + !elseif (associated(diag%axes%mask3d)) then ! used = send_data(diag_field_id, locfield, & ! is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, rmask=diag%axes%mask3d) else @@ -1150,7 +1150,7 @@ subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & is_in=isv, js_in=jsv, ie_in=iev, je_in=jev, & weight=diag_cs%time_int, rmask=mask) - elseif(associated(diag%axes%mask3d)) then + elseif (associated(diag%axes%mask3d)) then call assert(size(locfield) == size(diag%axes%mask3d), & 'post_data_3d_low: mask3d size mismatch: '//diag%debug_str) used = send_data(diag%fms_diag_id, locfield, diag_cs%time_end, & @@ -1333,7 +1333,7 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & logical :: active MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 @@ -1357,21 +1357,21 @@ integer function register_diag_field(module_name, field_name, axes, init_time, & ! Register diagnostics remapped to z vertical coordinate if (axes%rank == 3) then remap_axes => null() - if ((axes%id .eq. diag_cs%axesTL%id)) then + if ((axes%id == diag_cs%axesTL%id)) then remap_axes => diag_cs%remap_axesTL(i) - elseif(axes%id .eq. diag_cs%axesBL%id) then + elseif (axes%id == diag_cs%axesBL%id) then remap_axes => diag_cs%remap_axesBL(i) - elseif(axes%id .eq. diag_cs%axesCuL%id ) then + elseif (axes%id == diag_cs%axesCuL%id ) then remap_axes => diag_cs%remap_axesCuL(i) - elseif(axes%id .eq. diag_cs%axesCvL%id) then + elseif (axes%id == diag_cs%axesCvL%id) then remap_axes => diag_cs%remap_axesCvL(i) - elseif(axes%id .eq. diag_cs%axesTi%id) then + elseif (axes%id == diag_cs%axesTi%id) then remap_axes => diag_cs%remap_axesTi(i) - elseif(axes%id .eq. diag_cs%axesBi%id) then + elseif (axes%id == diag_cs%axesBi%id) then remap_axes => diag_cs%remap_axesBi(i) - elseif(axes%id .eq. diag_cs%axesCui%id ) then + elseif (axes%id == diag_cs%axesCui%id ) then remap_axes => diag_cs%remap_axesCui(i) - elseif(axes%id .eq. diag_cs%axesCvi%id) then + elseif (axes%id == diag_cs%axesCvi%id) then remap_axes => diag_cs%remap_axesCvi(i) endif ! When the MOM_diag_to_Z module has been obsoleted we can assume remap_axes will @@ -1453,7 +1453,7 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name, cm_string, msg MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value register_diag_field_expand_cmor = .false. diag_cs => axes%diag_cs @@ -1848,7 +1848,7 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name MOM_missing_value = diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value dm_id = -1 diag => null() @@ -1957,7 +1957,7 @@ function register_static_field(module_name, field_name, axes, & character(len=9) :: axis_name MOM_missing_value = axes%diag_cs%missing_value - if(present(missing_value)) MOM_missing_value = missing_value + if (present(missing_value)) MOM_missing_value = missing_value diag_cs => axes%diag_cs dm_id = -1 @@ -2520,7 +2520,7 @@ function i2s(a,n_in) integer :: i,n n=size(a) - if(present(n_in)) n = n_in + if (present(n_in)) n = n_in i2s = '' do i=1,n diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 5f5d927016..a2531fdac9 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -72,66 +72,76 @@ module MOM_file_parser end type parameter_block type, public :: param_file_type ; private - integer :: nfiles = 0 ! The number of open files. - integer :: iounit(MAX_PARAM_FILES) ! The unit number of an open file. - character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) ! The names of the open files. - logical :: NetCDF_file(MAX_PARAM_FILES)! If true, the input file is in NetCDF. + integer :: nfiles = 0 !< The number of open files. + integer :: iounit(MAX_PARAM_FILES) !< The unit numbers of open files. + character(len=FILENAME_LENGTH) :: filename(MAX_PARAM_FILES) !< The names of the open files. + logical :: NetCDF_file(MAX_PARAM_FILES) !< If true, the input file is in NetCDF. ! This is not yet implemented. - type(file_data_type) :: param_data(MAX_PARAM_FILES) ! Structures that contain - ! the valid data lines from the parameter - ! files, enabling all subsequent reads of - ! parameter data to occur internally. - logical :: report_unused = report_unused_default ! If true, report any - ! parameter lines that are not used in the run. - logical :: unused_params_fatal = unused_params_fatal_default ! If true, kill - ! the run if there are any unused parameters. - logical :: log_to_stdout = log_to_stdout_default ! If true, all log - ! messages are also sent to stdout. - logical :: log_open = .false. ! True if the log file has been opened. - integer :: stdout, stdlog ! The units from stdout() and stdlog(). - character(len=240) :: doc_file ! A file where all run-time parameters, their - ! settings and defaults are documented. - logical :: complete_doc = complete_doc_default ! If true, document all - ! run-time parameters. - logical :: minimal_doc = minimal_doc_default ! If true, document only those - ! run-time parameters that differ from defaults. - type(doc_type), pointer :: doc => NULL() ! A structure that contains information - ! related to parameter documentation. - type(link_parameter), pointer :: chain => NULL() ! Facilitates linked list - type(parameter_block), pointer :: blockName => NULL() ! Name of active parameter block + type(file_data_type) :: param_data(MAX_PARAM_FILES) !< Structures that contain + !! the valid data lines from the parameter + !! files, enabling all subsequent reads of + !! parameter data to occur internally. + logical :: report_unused = report_unused_default !< If true, report any + !! parameter lines that are not used in the run. + logical :: unused_params_fatal = unused_params_fatal_default !< If true, kill + !! the run if there are any unused parameters. + logical :: log_to_stdout = log_to_stdout_default !< If true, all log + !! messages are also sent to stdout. + logical :: log_open = .false. !< True if the log file has been opened. + integer :: stdout, stdlog !< The units from stdout() and stdlog(). + character(len=240) :: doc_file !< A file where all run-time parameters, their + !! settings and defaults are documented. + logical :: complete_doc = complete_doc_default !< If true, document all + !! run-time parameters. + logical :: minimal_doc = minimal_doc_default !< If true, document only those + !! run-time parameters that differ from defaults. + type(doc_type), pointer :: doc => NULL() !< A structure that contains information + !! related to parameter documentation. + type(link_parameter), pointer :: chain => NULL() !< Facilitates linked list + type(parameter_block), pointer :: blockName => NULL() !< Name of active parameter block end type param_file_type public read_param, open_param_file, close_param_file, log_param, log_version public doc_param, get_param public clearParameterBlock, openParameterBlock, closeParameterBlock +!> An overloaded interface to read various types of parameters interface read_param module procedure read_param_int, read_param_real, read_param_logical, & read_param_char, read_param_char_array, read_param_time, & read_param_int_array, read_param_real_array end interface +!> An overloaded interface to log the values of various types of parameters interface log_param module procedure log_param_int, log_param_real, log_param_logical, & log_param_char, log_param_time, & log_param_int_array, log_param_real_array end interface +!> An overloaded interface to log the values of various types of parameters interface get_param module procedure get_param_int, get_param_real, get_param_logical, & get_param_char, get_param_char_array, get_param_time, & get_param_int_array, get_param_real_array end interface + +!> An overloaded interface to log version information about modules interface log_version module procedure log_version_cs, log_version_plain end interface contains +!> Make the contents of a parameter input file availalble in a param_file_type subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) - character(len=*), intent(in) :: filename - type(param_file_type), intent(inout) :: CS - logical, optional, intent(in) :: checkable - character(len=*), optional, intent(in) :: component - character(len=*), optional, intent(in) :: doc_file_dir + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: checkable !< If this is false, it disables checks of this + !! file for unused parameters. The default is True. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names; the default is"MOM" + character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out + !! the documentation files. The default is effectively './'. logical :: file_exists, unit_in_use, Netcdf_file, may_check integer :: ios, iounit, strlen, i @@ -244,17 +254,23 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) end subroutine open_param_file +!> Close any open input files and deallocate memory associated with this param_file_type. +!! To use this type again, open_param_file would have to be called again. subroutine close_param_file(CS, quiet_close, component) - type(param_file_type), intent(inout) :: CS - logical, optional, intent(in) :: quiet_close - character(len=*), optional, intent(in) :: component + type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + logical, optional, intent(in) :: quiet_close !< if present and true, do not do any + !! logging with this call. + character(len=*), optional, intent(in) :: component !< If present, this component name is used + !! to generate parameter documentation file names ! Arguments: CS - the param_file_type to close ! (in,opt) quiet_close - if present and true, do not do any logging with this ! call. -! This include declares and sets the variable "version". -#include "version_variable.h" + character(len=128) :: docfile_default character(len=40) :: mdl ! This module's name. +! This include declares and sets the variable "version". +#include "version_variable.h" integer :: i, n, num_unused if (present(quiet_close)) then ; if (quiet_close) then @@ -337,10 +353,13 @@ subroutine close_param_file(CS, quiet_close, component) end subroutine close_param_file +!> Read the contents of a parameter input file, and store the contents in a +!! file_data_type after removing comments and simplifying white space subroutine populate_param_data(iounit, filename, param_data) - integer, intent(in) :: iounit - character(len=*), intent(in) :: filename - type(file_data_type), intent(inout) :: param_data + integer, intent(in) :: iounit !< The IO unit number that is open for filename + character(len=*), intent(in) :: filename !< An input file name, optionally with the full path + type(file_data_type), intent(inout) :: param_data !< A list of the input lines that set parameters + !! after comments have been stripped out. character(len=INPUT_STR_LENGTH) :: line integer :: num_lines @@ -432,8 +451,10 @@ subroutine populate_param_data(iounit, filename, param_data) end subroutine populate_param_data + +!> Return True if a /* appears on this line without a closing */ function openMultiLineComment(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process logical :: openMultiLineComment ! True if a /* appears on this line without a closing */ integer :: icom, last @@ -447,38 +468,43 @@ function openMultiLineComment(string) icom = index(string(last:), "*/") ; if (icom > 0) openMultiLineComment=.false. end function openMultiLineComment +!> Return True if a */ appears on this line function closeMultiLineComment(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process logical :: closeMultiLineComment ! True if a */ appears on this line closeMultiLineComment = .false. if (index(string, "*/")>0) closeMultiLineComment=.true. end function closeMultiLineComment +!> Find position of last character before any comments, As marked by "!", "//", or "/*" +!! following F90, C++, or C syntax function lastNonCommentIndex(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process integer :: lastNonCommentIndex ! Find position of last character before any comments ! This s/r is the only place where a comment needs to be defined integer :: icom, last last = len_trim(string) icom = index(string(:last), "!") ; if (icom > 0) last = icom-1 ! F90 style - icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C+ style + icom = index(string(:last), "//") ; if (icom > 0) last = icom-1 ! C++ style icom = index(string(:last), "/*") ; if (icom > 0) last = icom-1 ! C style lastNonCommentIndex = last end function lastNonCommentIndex +!> Find position of last non-blank character before any comments function lastNonCommentNonBlank(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process integer :: lastNonCommentNonBlank ! Find position of last non-blank character before any comments lastNonCommentNonBlank = len_trim(string(:lastNonCommentIndex(string))) ! Ignore remaining trailing blanks end function lastNonCommentNonBlank +!> Returns a string with tabs replaced by a blank function replaceTabs(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process character(len=len(string)) :: replaceTabs -! Returns string with tabs replaced by a ablank +! Returns string with tabs replaced by a blank integer :: i do i=1, len(string) if (string(i:i)==achar(9)) then @@ -489,8 +515,9 @@ function replaceTabs(string) enddo end function replaceTabs +!> Trims comments and leading blanks from string function removeComments(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< The input string to process character(len=len(string)) :: removeComments ! Trims comments and leading blanks from string integer :: last @@ -499,8 +526,10 @@ function removeComments(string) removeComments(:last)=adjustl(string(:last)) ! Copy only the non-comment part of string end function removeComments +!> Constructs a string with all repeated whitespace replaced with single blanks +!! and insert white space where it helps delineate tokens (e.g. around =) function simplifyWhiteSpace(string) - character(len=*), intent(in) :: string + character(len=*), intent(in) :: string !< A string to modify to simpify white space character(len=len(string)+16) :: simplifyWhiteSpace ! Constructs a string with all repeated whitespace replaced with single blanks ! and insert white space where it helps delineate tokens (e.g. around =) @@ -551,11 +580,15 @@ function simplifyWhiteSpace(string) endif end function simplifyWhiteSpace +!> This subroutine reads the value of an integer model parameter from a parameter file. subroutine read_param_int(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - integer, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -583,11 +616,14 @@ subroutine read_param_int(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_int +!> This subroutine reads the values of an array of integer model parameters from a parameter file. subroutine read_param_int_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - integer, intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for this parameter, which is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -616,11 +652,15 @@ subroutine read_param_int_array(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_int_array +!> This subroutine reads the value of a real model parameter from a parameter file. subroutine read_param_real(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - real, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -648,11 +688,15 @@ subroutine read_param_real(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_real +!> This subroutine reads the values of an array of real model parameters from a parameter file. subroutine read_param_real_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - real, intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -681,11 +725,15 @@ subroutine read_param_real_array(CS, varname, value, fail_if_missing) ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_real_array +!> This subroutine reads the value of a character string model parameter from a parameter file. subroutine read_param_char(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -704,11 +752,15 @@ subroutine read_param_char(CS, varname, value, fail_if_missing) end subroutine read_param_char +!> This subroutine reads the values of an array of character string model parameters from a parameter file. subroutine read_param_char_array(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value(:) - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -741,11 +793,15 @@ subroutine read_param_char_array(CS, varname, value, fail_if_missing) end subroutine read_param_char_array +!> This subroutine reads the value of a logical model parameter from a parameter file. subroutine read_param_logical(CS, varname, value, fail_if_missing) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - logical, intent(inout) :: value - logical, optional, intent(in) :: fail_if_missing + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file ! This subroutine determines the value of an integer model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -763,14 +819,19 @@ subroutine read_param_logical(CS, varname, value, fail_if_missing) endif ; endif end subroutine read_param_logical - +!> This subroutine reads the value of a time_type model parameter from a parameter file. subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_format) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - type(time_type), intent(inout) :: value - real, optional, intent(in) :: timeunit - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(out) :: date_format + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for real-number input. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(out) :: date_format !< If present, this indicates whether this + !! parameter was read in a date format, so that it can + !! later be logged in the same format. ! This subroutine determines the value of an time-type model parameter ! from a parameter file. The arguments are the unit of the open file ! which is to be read, the (case-sensitive) variable name, the variable @@ -834,8 +895,9 @@ subroutine read_param_time(CS, varname, value, timeunit, fail_if_missing, date_f trim(varname)// ' parsing "'//trim(value_string(1))//'"') end subroutine read_param_time +!> This function removes single and double quotes from a character string function strip_quotes(val_str) - character(len=*) :: val_str + character(len=*) :: val_str !< The character string to work on character(len=INPUT_STR_LENGTH) :: strip_quotes ! Local variables integer :: i @@ -854,12 +916,18 @@ function strip_quotes(val_str) enddo end function strip_quotes +!> This subtoutine extracts the contents of lines in the param_file_type that refer to +!! a named parameter. The value_string that is returned must be interepreted in a way +!! that depends on the type of this variable. subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsLogical) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: varname - logical, intent(out) :: found, defined - character(len=*), intent(out) :: value_string(:) - logical, optional, intent(in) :: paramIsLogical + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(out) :: found !< If true, this parameter has been found in CS + logical, intent(out) :: defined !< If true, this parameter is set (or true) in the CS + character(len=*), intent(out) :: value_string(:) !< A string that encodes the new value + logical, optional, intent(in) :: paramIsLogical !< If true, this is a logical parameter + !! that can be simply defined without parsing a value_string. character(len=INPUT_STR_LENGTH) :: val_str, lname, origLine character(len=INPUT_STR_LENGTH) :: line, continuationBuffer, blockName @@ -885,7 +953,7 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL ! return variables indicating whether this variable is defined and the string ! that contains the value of this variable. found = .false. - oval = 0; ival = 0; + oval = 0; ival = 0 max_vals = SIZE(value_string) do is=1,max_vals ; value_string(is) = " " ; enddo @@ -1170,15 +1238,17 @@ subroutine get_variable_line(CS, varname, found, defined, value_string, paramIsL end subroutine get_variable_line -subroutine flag_line_as_read(line_used,count) - logical, dimension(:), pointer :: line_used - integer, intent(in) :: count +!> Record that a line has been used to set a parameter +subroutine flag_line_as_read(line_used, count) + logical, dimension(:), pointer :: line_used !< A structure indicating which lines have been read + integer, intent(in) :: count !< The parameter on this line number has been read line_used(count) = .true. end subroutine flag_line_as_read +!> Returns true if an override warning has been issued for the variable varName function overrideWarningHasBeenIssued(chain, varName) type(link_parameter), pointer :: chain - character(len=*), intent(in) :: varName + character(len=*), intent(in) :: varName !< The name of the variable being queried for warnings logical :: overrideWarningHasBeenIssued ! Returns true if an override warning has been issued for the variable varName type(link_parameter), pointer :: newLink, this @@ -1234,16 +1304,22 @@ subroutine log_version_plain(modulename, version) end subroutine log_version_plain +!> Log the name and value of an integer model parameter in documentation files. subroutine log_param_int(CS, modulename, varname, value, desc, units, & default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of an integer parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1261,16 +1337,21 @@ subroutine log_param_int(CS, modulename, varname, value, desc, units, & end subroutine log_param_int +!> Log the name and values of an array of integer model parameter in documentation files. subroutine log_param_int_array(CS, modulename, varname, value, desc, & units, default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(in) :: value(:) - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the module using this parameter + character(len=*), intent(in) :: varname !< The name of the parameter to log + integer, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of an integer parameter to a log file, ! along with its name and the module it came from. character(len=1320) :: mesg @@ -1289,15 +1370,20 @@ subroutine log_param_int_array(CS, modulename, varname, value, desc, & end subroutine log_param_int_array +!> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & default, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1316,14 +1402,18 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & end subroutine log_param_real +!> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & units, default) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(in) :: value(:) - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + real, dimension(:), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. character(len=1320) :: mesg @@ -1345,16 +1435,22 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & end subroutine log_param_real_array +!> Log the name and value of a logical model parameter in documentation files. subroutine log_param_logical(CS, modulename, varname, value, desc, & units, default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - logical, intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - logical, optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + logical, intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + logical, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a logical parameter to a log file, ! along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1376,16 +1472,22 @@ subroutine log_param_logical(CS, modulename, varname, value, desc, & end subroutine log_param_logical +!> Log the name and value of a character string model parameter in documentation files. subroutine log_param_char(CS, modulename, varname, value, desc, units, & default, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + character(len=*), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a character string parameter to a log ! file, along with its name and the module it came from. character(len=240) :: mesg, myunits @@ -1408,16 +1510,23 @@ end subroutine log_param_char !! along with its name and the module it came from. subroutine log_param_time(CS, modulename, varname, value, desc, units, & default, timeunit, layoutParam, debuggingParam, log_date) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - type(time_type), intent(in) :: value - character(len=*), optional, intent(in) :: desc, units - type(time_type), optional, intent(in) :: default - real, optional, intent(in) :: timeunit + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The name of the parameter to log + type(time_type), intent(in) :: value !< The value of the parameter to log + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + type(time_type), optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number output. logical, optional, intent(in) :: log_date !< If true, log the time_type in date format. - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + !! If missing the default is false. + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file real :: real_time, real_default logical :: use_timeunit, date_format @@ -1516,19 +1625,34 @@ function convert_date_to_string(date) result(date_string) end function convert_date_to_string +!> This subroutine reads the value of an integer model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_int(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + integer, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1549,19 +1673,33 @@ subroutine get_param_int(CS, modulename, varname, value, desc, units, & end subroutine get_param_int +!> This subroutine reads the values of an array of integer model parameters from a parameter file +!! and logs them in documentation files. subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - integer, intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - integer, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + integer, dimension(:), intent(inout) :: value !< The value of the parameter that may be reset from the parameter file + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + integer, optional, intent(in) :: default !< The default value of the parameter + integer, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1582,18 +1720,32 @@ subroutine get_param_int_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_int_array +!> This subroutine reads the value of a real model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_real(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1614,18 +1766,30 @@ subroutine get_param_real(CS, modulename, varname, value, desc, units, & end subroutine get_param_real +!> This subroutine reads the values of an array of real model parameters from a parameter file +!! and logs them in documentation files. subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, static_value) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - real, intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - real, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log -! This subroutine writes the value of a real parameter to a log file, -! along with its name and the module it came from. + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + real, dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + real, optional, intent(in) :: default !< The default value of the parameter + real, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical :: do_read, do_log do_read = .true. ; if (present(do_not_read)) do_read = .not.do_not_read @@ -1644,19 +1808,34 @@ subroutine get_param_real_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_real_array +!> This subroutine reads the value of a character string model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_char(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1677,16 +1856,29 @@ subroutine get_param_char(CS, modulename, varname, value, desc, units, & end subroutine get_param_char +!> This subroutine reads the values of an array of character string model parameters +!! from a parameter file and logs them in documentation files. subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, static_value) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - character(len=*), intent(inout) :: value(:) - character(len=*), optional, intent(in) :: desc, units - character(len=*), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + character(len=*), dimension(:), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + character(len=*), optional, intent(in) :: default !< The default value of the parameter + character(len=*), optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1717,19 +1909,34 @@ subroutine get_param_char_array(CS, modulename, varname, value, desc, units, & end subroutine get_param_char_array +!> This subroutine reads the value of a logical model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_logical(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & static_value, layoutParam, debuggingParam) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - logical, intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - logical, optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + logical, intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + logical, optional, intent(in) :: default !< The default value of the parameter + logical, optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log @@ -1750,22 +1957,39 @@ subroutine get_param_logical(CS, modulename, varname, value, desc, units, & end subroutine get_param_logical +!> This subroutine reads the value of a time-type model parameter from a parameter file +!! and logs it in documentation files. subroutine get_param_time(CS, modulename, varname, value, desc, units, & default, fail_if_missing, do_not_read, do_not_log, & timeunit, static_value, layoutParam, debuggingParam, & log_as_date) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: modulename - character(len=*), intent(in) :: varname - type(time_type), intent(inout) :: value - character(len=*), optional, intent(in) :: desc, units - type(time_type), optional, intent(in) :: default, static_value - logical, optional, intent(in) :: fail_if_missing - logical, optional, intent(in) :: do_not_read, do_not_log - real, optional, intent(in) :: timeunit - logical, optional, intent(in) :: layoutParam - logical, optional, intent(in) :: debuggingParam - logical, optional, intent(in) :: log_as_date + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: modulename !< The name of the calling module + character(len=*), intent(in) :: varname !< The case-sensitive name of the parameter to read + type(time_type), intent(inout) :: value !< The value of the parameter that may be + !! read from the parameter file and logged + character(len=*), optional, intent(in) :: desc !< A description of this variable; if not + !! present, this paramter is not written to a doc file + character(len=*), optional, intent(in) :: units !< The units of this parameter + type(time_type), optional, intent(in) :: default !< The default value of the parameter + type(time_type), optional, intent(in) :: static_value !< If this parameter is static, it takes + !! this value, which can be compared for consistency with + !! what is in the parameter file. + logical, optional, intent(in) :: fail_if_missing !< If present and true, a fatal error occurs + !! if this variable is not found in the parameter file + logical, optional, intent(in) :: do_not_read !< If present and true, do not read a + !! value for this parameter, although it might be logged. + logical, optional, intent(in) :: do_not_log !< If present and true, do not log this + !! parameter to the documentation files + real, optional, intent(in) :: timeunit !< The number of seconds in a time unit for + !! real-number input to be translated to a time. + logical, optional, intent(in) :: layoutParam !< If present and true, this paramter is + !! logged in the layout parameter file + logical, optional, intent(in) :: debuggingParam !< If present and true, this paramter is + !! logged in the debugging parameter file + logical, optional, intent(in) :: log_as_date !< If true, log the time_type in date + !! format. The default is false. ! This subroutine writes the value of a real parameter to a log file, ! along with its name and the module it came from. logical :: do_read, do_log, date_format, log_date @@ -1791,8 +2015,10 @@ end subroutine get_param_time ! ----------------------------------------------------------------------------- +!> Resets the parameter block name to blank subroutine clearParameterBlock(CS) - type(param_file_type), intent(in) :: CS + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters ! Resets the parameter block name to blank type(parameter_block), pointer :: block if (associated(CS%blockName)) then @@ -1804,10 +2030,12 @@ subroutine clearParameterBlock(CS) endif end subroutine clearParameterBlock +!> Tags blockName onto the end of the active parameter block name subroutine openParameterBlock(CS,blockName,desc) - type(param_file_type), intent(in) :: CS - character(len=*), intent(in) :: blockName - character(len=*), optional, intent(in) :: desc + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters + character(len=*), intent(in) :: blockName !< The name of a parameter block being added + character(len=*), optional, intent(in) :: desc !< A description of the parameter block being added ! Tags blockName onto the end of the active parameter block name type(parameter_block), pointer :: block if (associated(CS%blockName)) then @@ -1820,8 +2048,10 @@ subroutine openParameterBlock(CS,blockName,desc) endif end subroutine openParameterBlock +!> Remove the lowest level of recursion from the active block name subroutine closeParameterBlock(CS) - type(param_file_type), intent(in) :: CS + type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, + !! it is also a structure to parse for run-time parameters ! Remove the lowest level of recursion from the active block name type(parameter_block), pointer :: block @@ -1838,8 +2068,10 @@ subroutine closeParameterBlock(CS) block%name = popBlockLevel(block%name) end subroutine closeParameterBlock +!> Extends block name (deeper level of parameter block) function pushBlockLevel(oldblockName,newBlockName) - character(len=*), intent(in) :: oldBlockName, newBlockName + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names + character(len=*), intent(in) :: newBlockName !< A new block name to add to the end of the sequence character(len=len(oldBlockName)+40) :: pushBlockLevel ! Extends block name (deeper level of parameter block) if (len_trim(oldBlockName)>0) then @@ -1849,8 +2081,9 @@ function pushBlockLevel(oldblockName,newBlockName) endif end function pushBlockLevel +!> Truncates block name (shallower level of parameter block) function popBlockLevel(oldblockName) - character(len=*), intent(in) :: oldBlockName + character(len=*), intent(in) :: oldBlockName !< A sequence of hierarchical parameter block names character(len=len(oldBlockName)+40) :: popBlockLevel ! Truncates block name (shallower level of parameter block) integer :: i diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 4326693957..5a626dd934 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -118,9 +118,9 @@ end subroutine HIT_assign !! The non-symmetric memory mode will then also work, albeit with a different (less efficient) communication pattern. !! !! Using the hor_index_type HI: -!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)`; -!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)`; -!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)`; +!! - declaration of h-point data is of the form `h(HI%%isd:HI%%ied,HI%%jsd:HI%%jed)` +!! - declaration of q-point data is of the form `q(HI%%IsdB:HI%%IedB,HI%%JsdB:HI%%JedB)` +!! - declaration of u-point data is of the form `u(HI%%IsdB:HI%%IedB,HI%%jsd:HI%%jed)` !! - declaration of v-point data is of the form `v(HI%%isd:HI%%ied,HI%%JsdB:HI%%JedB)`. !! !! For more detail explanation of horizontal indexing see \ref Horizontal_indexing. diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index db65a9504c..176e6e6d13 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -191,15 +191,15 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug do j=js,je i_loop: do i=is,ie - if (good_(i,j) .eq. 1.0 .or. fill(i,j) .eq. 0.) cycle i_loop + if (good_(i,j) == 1.0 .or. fill(i,j) == 0.) cycle i_loop ge=good_(i+1,j);gw=good_(i-1,j) gn=good_(i,j+1);gs=good_(i,j-1) east=0.0;west=0.0;north=0.0;south=0.0 - if (ge.eq.1.0) east=aout(i+1,j)*ge - if (gw.eq.1.0) west=aout(i-1,j)*gw - if (gn.eq.1.0) north=aout(i,j+1)*gn - if (gs.eq.1.0) south=aout(i,j-1)*gs + if (ge == 1.0) east=aout(i+1,j)*ge + if (gw == 1.0) west=aout(i-1,j)*gw + if (gn == 1.0) north=aout(i,j+1)*gn + if (gs == 1.0) south=aout(i,j-1)*gs ngood = ge+gw+gn+gs if (ngood > 0.) then @@ -219,13 +219,13 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug if (nfill == nfill_prev .and. PRESENT(prev)) then do j=js,je do i=is,ie - if (fill_pts(i,j).eq.1.0) then + if (fill_pts(i,j) == 1.0) then aout(i,j)=prev(i,j) fill_pts(i,j)=0.0 endif enddo enddo - else if (nfill .eq. nfill_prev) then + else if (nfill == nfill_prev) then print *,& 'Unable to fill missing points using either data at the same vertical level from a connected basin'//& 'or using a point from a previous vertical level. Make sure that the original data has some valid'//& @@ -243,7 +243,7 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug call pass_var(aout,G%Domain) do j=js,je do i=is,ie - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then east=max(good(i+1,j),fill(i+1,j)) ; west=max(good(i-1,j),fill(i-1,j)) north=max(good(i,j+1),fill(i,j+1)) ; south=max(good(i,j-1),fill(i,j-1)) !### Appropriate parentheses should be added here, but they will change answers. @@ -264,7 +264,7 @@ subroutine fill_miss_2d(aout,good,fill,prev,G,smooth,num_pass,relc,crit,keep_bug do j=js,je do i=is,ie - if (good_(i,j).eq.0.0 .and. fill_pts(i,j) .eq. 1.0) then + if (good_(i,j) == 0.0 .and. fill_pts(i,j) == 1.0) then print *,'in fill_miss, fill, good,i,j= ',fill_pts(i,j),good_(i,j),i,j call MOM_error(FATAL,"MOM_initialize: "// & "fill is true and good is false after fill_miss, how did this happen? ") @@ -348,40 +348,40 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, rcode = NF90_OPEN(filename, NF90_NOWRITE, ncid) - if (rcode .ne. 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& + if (rcode /= 0) call MOM_error(FATAL,"error opening file "//trim(filename)//& " in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, varnam, varid) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(varnam)//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_VARIABLE(ncid, varid, ndims=ndims, dimids=dims) - if (rcode .ne. 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') + if (rcode /= 0) call MOM_error(FATAL,'error inquiring dimensions hinterp_extrap') if (ndims < 3) call MOM_error(FATAL,"Variable "//trim(varnam)//" in file "// & trim(filename)//" has too few dimensions.") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(2), dim_name(2), len=jd) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(2), dim_id(2)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(2))//& " in file "//trim(filename)//" in hinterp_extrap") rcode = NF90_INQUIRE_DIMENSION(ncid, dims(3), dim_name(3), len=kd) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 data for "// & trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") rcode = NF90_INQ_VARID(ncid, dim_name(3), dim_id(3)) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& + if (rcode /= 0) call MOM_error(FATAL,"error finding variable "//trim(dim_name(3))//& " in file "//trim(filename)//" in hinterp_extrap") missing_value=0.0 rcode = NF90_GET_ATT(ncid, varid, "_FillValue", missing_value) - if (rcode .ne. 0) call MOM_error(FATAL,"error finding missing value for "//& + if (rcode /= 0) call MOM_error(FATAL,"error finding missing value for "//& trim(varnam)//" in file "// trim(filename)//" in hinterp_extrap") if (allocated(lon_in)) deallocate(lon_in) @@ -397,15 +397,15 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, start = 1; count = 1; count(1) = id rcode = NF90_GET_VAR(ncid, dim_id(1), lon_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 1 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(1))//" in file "// trim(filename)//" in hinterp_extrap") start = 1; count = 1; count(1) = jd rcode = NF90_GET_VAR(ncid, dim_id(2), lat_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 2 values for var_name "// & trim(varnam)//",dim_name "//trim(dim_name(2))//" in file "// trim(filename)//" in hinterp_extrap") start = 1; count = 1; count(1) = kd rcode = NF90_GET_VAR(ncid, dim_id(3), z_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & + if (rcode /= 0) call MOM_error(FATAL,"error reading dimension 3 values for var_name "// & trim(varnam//",dim_name "//trim(dim_name(3)))//" in file "// trim(filename)//" in hinterp_extrap") call cpu_clock_end(id_clock_read) @@ -470,14 +470,14 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (is_root_pe()) then start = 1; start(3) = k; count = 1; count(1) = id; count(2) = jd rcode = NF90_GET_VAR(ncid,varid, tr_in, start, count) - if (rcode .ne. 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& + if (rcode /= 0) call MOM_error(FATAL,"hinterp_and_extract_from_Fie: "//& "error reading level "//trim(laynum)//" of variable "//& trim(varnam)//" in file "// trim(filename)) if (add_np) then last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then pole = pole+last_row(i) npole = npole+1.0 endif @@ -497,13 +497,13 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call mpp_sync() call mpp_broadcast(tr_inp,id*jdp,root_PE()) - call mpp_sync_self () + call mpp_sync_self() mask_in=0.0 do j=1,jdp do i=1,id - if (abs(tr_inp(i,j)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then mask_in(i,j)=1.0 tr_inp(i,j) = tr_inp(i,j) * conversion else @@ -532,7 +532,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, mask_out=1.0 do j=js,je do i=is,ie - if (abs(tr_out(i,j)-missing_value) .lt. abs(roundoff*missing_value)) mask_out(i,j)=0. + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. enddo enddo @@ -541,14 +541,14 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, nPoints = 0 ; varAvg = 0. do j=js,je do i=is,ie - if (mask_out(i,j) .lt. 1.0) then + if (mask_out(i,j) < 1.0) then tr_out(i,j)=missing_value else good(i,j)=1.0 nPoints = nPoints + 1 varAvg = varAvg + tr_out(i,j) endif - if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) .lt. 1.0) fill(i,j)=1.0 + if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) < 1.0) fill(i,j)=1.0 enddo enddo call pass_var(fill,G%Domain) @@ -750,7 +750,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t if (add_np) then last_row(:)=tr_in(:,jd); pole=0.0;npole=0.0 do i=1,id - if (abs(tr_in(i,jd)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_in(i,jd)-missing_value) > abs(roundoff*missing_value)) then pole = pole+last_row(i) npole = npole+1.0 endif @@ -770,13 +770,13 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call mpp_sync() call mpp_broadcast(tr_inp,id*jdp,root_PE()) - call mpp_sync_self () + call mpp_sync_self() mask_in=0.0 do j=1,jdp do i=1,id - if (abs(tr_inp(i,j)-missing_value) .gt. abs(roundoff*missing_value)) then + if (abs(tr_inp(i,j)-missing_value) > abs(roundoff*missing_value)) then mask_in(i,j)=1.0 tr_inp(i,j) = tr_inp(i,j) * conversion else @@ -805,7 +805,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t mask_out=1.0 do j=js,je do i=is,ie - if (abs(tr_out(i,j)-missing_value) .lt. abs(roundoff*missing_value)) mask_out(i,j)=0. + if (abs(tr_out(i,j)-missing_value) < abs(roundoff*missing_value)) mask_out(i,j)=0. enddo enddo @@ -814,14 +814,14 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t nPoints = 0 ; varAvg = 0. do j=js,je do i=is,ie - if (mask_out(i,j) .lt. 1.0) then + if (mask_out(i,j) < 1.0) then tr_out(i,j)=missing_value else good(i,j)=1.0 nPoints = nPoints + 1 varAvg = varAvg + tr_out(i,j) endif - if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) .lt. 1.0) fill(i,j)=1.0 + if (G%mask2dT(i,j) == 1.0 .and. z_edges_in(k) <= G%bathyT(i,j) .and. mask_out(i,j) < 1.0) fill(i,j)=1.0 enddo enddo call pass_var(fill,G%Domain) @@ -982,7 +982,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) endif @@ -992,7 +992,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do n=1,niter do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) Isum = 1.0/bsum res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 54ce188bb9..079ac6ba3a 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -323,7 +323,7 @@ subroutine create_file(unit, filename, vars, novars, fields, threading, timeunit end select pack = 1 - if(present(checksums)) then + if (present(checksums)) then call mpp_write_meta(unit, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack = pack, checksum=checksums(k,:)) else @@ -426,7 +426,7 @@ subroutine reopen_file(unit, filename, vars, novars, fields, threading, timeunit ! call mpp_get_field_atts(fields(i),name) ! !if (trim(name) /= trim(vars%name) then ! !write (mesg,'("Reopening file ",a," variable ",a," is called ",a,".")',& -! ! filename,vars%name,name); +! ! filename,vars%name,name) ! !call MOM_error(NOTE,"MOM_io: "//mesg) ! enddo endif diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index d397dede55..6944647008 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -914,9 +914,9 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV) !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) - if(restartname(length-2:length) == '.nc') then + if (restartname(length-2:length) == '.nc') then restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) @@ -1265,7 +1265,7 @@ subroutine restore_state(filename, directory, day, G, CS) endif endif - if(is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then + if (is_root_pe() .and. is_there_a_checksum .and. (checksum_file(1) /= checksum_data)) then write (mesg,'(a,Z16,a,Z16,a)') "Checksum of input field "// trim(varname)//" ",checksum_data,& " does not match value ", checksum_file(1), & " stored in "//trim(unit_path(n)//"." ) @@ -1447,9 +1447,9 @@ function open_restart_units(filename, directory, G, CS, units, file_paths, & !query fms_io if there is a filename_appendix (for ensemble runs) call get_filename_appendix(filename_appendix) - if(len_trim(filename_appendix) > 0) then + if (len_trim(filename_appendix) > 0) then length = len_trim(restartname) - if(restartname(length-2:length) == '.nc') then + if (restartname(length-2:length) == '.nc') then restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' else restartname = restartname(1:length) //'.'//trim(filename_appendix) diff --git a/src/framework/MOM_safe_alloc.F90 b/src/framework/MOM_safe_alloc.F90 index 196a6b40e6..5b4d331645 100644 --- a/src/framework/MOM_safe_alloc.F90 +++ b/src/framework/MOM_safe_alloc.F90 @@ -14,11 +14,13 @@ module MOM_safe_alloc public safe_alloc_ptr, safe_alloc_alloc +!> Allocate a pointer to a 1-d, 2-d or 3-d array interface safe_alloc_ptr module procedure safe_alloc_ptr_3d_2arg, safe_alloc_ptr_2d_2arg module procedure safe_alloc_ptr_3d, safe_alloc_ptr_2d, safe_alloc_ptr_1d end interface safe_alloc_ptr +!> Allocate a 2-d or 3-d allocatable array interface safe_alloc_alloc module procedure safe_alloc_allocatable_3d, safe_alloc_allocatable_2d end interface safe_alloc_alloc @@ -34,10 +36,11 @@ module MOM_safe_alloc contains +!> Allocate a pointer to a 1-d array subroutine safe_alloc_ptr_1d(ptr, i1, i2) - real, pointer :: ptr(:) - integer, intent(in) :: i1 - integer, optional, intent(in) :: i2 + real, dimension(:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: i1 !< The size of the array, or its starting index if i2 is present + integer, optional, intent(in) :: i2 !< The ending index of the array if (.not.associated(ptr)) then if (present(i2)) then allocate(ptr(i1:i2)) @@ -48,54 +51,67 @@ subroutine safe_alloc_ptr_1d(ptr, i1, i2) endif end subroutine safe_alloc_ptr_1d +!> Allocate a pointer to a 2-d array based on its dimension sizes subroutine safe_alloc_ptr_2d_2arg(ptr, ni, nj) - real, pointer :: ptr(:,:) - integer, intent(in) :: ni, nj + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni, nj !< The sizes of the 1st and 2nd dimensions of the array if (.not.associated(ptr)) then allocate(ptr(ni,nj)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_ptr_2d_2arg +!> Allocate a pointer to a 3-d array based on its dimension sizes subroutine safe_alloc_ptr_3d_2arg(ptr, ni, nj, nk) - real, pointer :: ptr(:,:,:) - integer, intent(in) :: ni, nj, nk + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: ni, nj !< The sizes of the 1st and 2nd dimensions of the array + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension if (.not.associated(ptr)) then allocate(ptr(ni,nj,nk)) ptr(:,:,:) = 0.0 endif end subroutine safe_alloc_ptr_3d_2arg +!> Allocate a pointer to a 2-d array based on its index starting and ending values subroutine safe_alloc_ptr_2d(ptr, is, ie, js, je) - real, pointer :: ptr(:,:) - integer, intent(in) :: is, ie, js, je + real, dimension(:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension if (.not.associated(ptr)) then allocate(ptr(is:ie,js:je)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_ptr_2d +!> Allocate a pointer to a 3-d array based on its index starting and ending values subroutine safe_alloc_ptr_3d(ptr, is, ie, js, je, nk) - real, pointer :: ptr(:,:,:) - integer, intent(in) :: is, ie, js, je, nk + real, dimension(:,:,:), pointer :: ptr !< A pointer to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension if (.not.associated(ptr)) then allocate(ptr(is:ie,js:je,nk)) ptr(:,:,:) = 0.0 endif end subroutine safe_alloc_ptr_3d +!> Allocate a 2-d allocatable array based on its index starting and ending values subroutine safe_alloc_allocatable_2d(ptr, is, ie, js, je) - real, allocatable :: ptr(:,:) - integer, intent(in) :: is, ie, js, je + real, dimension(:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension if (.not.allocated(ptr)) then allocate(ptr(is:ie,js:je)) ptr(:,:) = 0.0 endif end subroutine safe_alloc_allocatable_2d +!> Allocate a 3-d allocatable array based on its index starting and ending values subroutine safe_alloc_allocatable_3d(ptr, is, ie, js, je, nk) - real, allocatable :: ptr(:,:,:) - integer, intent(in) :: is, ie, js, je, nk + real, dimension(:,:,:), allocatable :: ptr !< An allocatable array to allocate + integer, intent(in) :: is, ie !< The start and end indices to allocate for the 1st dimension + integer, intent(in) :: js, je !< The start and end indices to allocate for the 2nd dimension + integer, intent(in) :: nk !< The size to allocate for the 3rd dimension if (.not.allocated(ptr)) then allocate(ptr(is:ie,js:je,nk)) ptr(:,:,:) = 0.0 diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index aa9b11bda6..f56834a8f6 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -224,7 +224,7 @@ end function extractWord extract_word = '' lastCharIsSeperator = .true. ns = len_trim(string) - i = 0; b=0; e=0; nw=0; + i = 0; b=0; e=0; nw=0 do while (i 0.0) then - call ice_shelf_min_thickness_calve (CS,last_h_shelf,last_area_shelf_h,last_hmask) + call ice_shelf_min_thickness_calve(CS,last_h_shelf,last_area_shelf_h,last_hmask) ! convert to mass again last_mass_shelf = last_h_shelf * CS%density_ice endif @@ -1268,7 +1268,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call get_param(param_file, mdl, "GROUNDING_LINE_COUPLE", CS%GL_couple, & "THIS PARAMETER NEEDS A DESCRIPTION.", default=.false.) if (CS%GL_regularize) CS%GL_couple = .false. - if (CS%GL_regularize .and. (CS%n_sub_regularize.eq.0)) call MOM_error (FATAL, & + if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") endif call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & @@ -1523,45 +1523,45 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl allocate( CS%exch_vel_s(isd:ied,jsd:jed) ) ; CS%exch_vel_s(:,:) = 0.0 allocate( CS%exch_vel_t(isd:ied,jsd:jed) ) ; CS%exch_vel_t(:,:) = 0.0 - allocate ( CS%h_shelf(isd:ied,jsd:jed) ) ; CS%h_shelf(:,:) = 0.0 - allocate ( CS%hmask(isd:ied,jsd:jed) ) ; CS%hmask(:,:) = -2.0 + allocate( CS%h_shelf(isd:ied,jsd:jed) ) ; CS%h_shelf(:,:) = 0.0 + allocate( CS%hmask(isd:ied,jsd:jed) ) ; CS%hmask(:,:) = -2.0 ! OVS vertically integrated Temperature - allocate ( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 - allocate ( CS%t_boundary_values(isd:ied,jsd:jed) ) ; CS%t_boundary_values(:,:) = -15.0 - allocate ( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 + allocate( CS%t_shelf(isd:ied,jsd:jed) ) ; CS%t_shelf(:,:) = -10.0 + allocate( CS%t_boundary_values(isd:ied,jsd:jed) ) ; CS%t_boundary_values(:,:) = -15.0 + allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%tmask(:,:) = -1.0 if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then ! DNG - allocate ( CS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_shelf(:,:) = 0.0 - allocate ( CS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_shelf(:,:) = 0.0 - allocate ( CS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_boundary_values(:,:) = 0.0 - allocate ( CS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_boundary_values(:,:) = 0.0 - allocate ( CS%h_boundary_values(isd:ied,jsd:jed) ) ; CS%h_boundary_values(:,:) = 0.0 - allocate ( CS%thickness_boundary_values(isd:ied,jsd:jed) ) ; CS%thickness_boundary_values(:,:) = 0.0 - allocate ( CS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; CS%ice_visc_bilinear(:,:) = 0.0 - allocate ( CS%ice_visc_lower_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_lower_tri = 0.0 - allocate ( CS%ice_visc_upper_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_upper_tri = 0.0 - allocate ( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 - allocate ( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 - allocate ( CS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_boundary(:,:) = -2.0 - allocate ( CS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_boundary(:,:) = -2.0 - allocate ( CS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_boundary_values(:,:) = 0.0 - allocate ( CS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_boundary_values(:,:) = 0.0 - allocate ( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 - allocate ( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 - - allocate ( CS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_bilinear(:,:) = 0.0 - allocate ( CS%taub_beta_eff_upper_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_upper_tri(:,:) = 0.0 - allocate ( CS%taub_beta_eff_lower_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_lower_tri(:,:) = 0.0 - allocate ( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 - allocate ( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 - allocate ( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 - allocate ( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 + allocate( CS%u_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_shelf(:,:) = 0.0 + allocate( CS%v_shelf(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_shelf(:,:) = 0.0 + allocate( CS%u_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%u_boundary_values(:,:) = 0.0 + allocate( CS%v_boundary_values(Isdq:Iedq,Jsdq:Jedq) ) ; CS%v_boundary_values(:,:) = 0.0 + allocate( CS%h_boundary_values(isd:ied,jsd:jed) ) ; CS%h_boundary_values(:,:) = 0.0 + allocate( CS%thickness_boundary_values(isd:ied,jsd:jed) ) ; CS%thickness_boundary_values(:,:) = 0.0 + allocate( CS%ice_visc_bilinear(isd:ied,jsd:jed) ) ; CS%ice_visc_bilinear(:,:) = 0.0 + allocate( CS%ice_visc_lower_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_lower_tri = 0.0 + allocate( CS%ice_visc_upper_tri(isd:ied,jsd:jed) ) ; CS%ice_visc_upper_tri = 0.0 + allocate( CS%u_face_mask(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask(:,:) = 0.0 + allocate( CS%v_face_mask(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask(:,:) = 0.0 + allocate( CS%u_face_mask_boundary(Isdq:Iedq,jsd:jed) ) ; CS%u_face_mask_boundary(:,:) = -2.0 + allocate( CS%v_face_mask_boundary(isd:ied,Jsdq:Jedq) ) ; CS%v_face_mask_boundary(:,:) = -2.0 + allocate( CS%u_flux_boundary_values(Isdq:Iedq,jsd:jed) ) ; CS%u_flux_boundary_values(:,:) = 0.0 + allocate( CS%v_flux_boundary_values(isd:ied,Jsdq:Jedq) ) ; CS%v_flux_boundary_values(:,:) = 0.0 + allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%umask(:,:) = -1.0 + allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq) ) ; CS%vmask(:,:) = -1.0 + + allocate( CS%taub_beta_eff_bilinear(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_bilinear(:,:) = 0.0 + allocate( CS%taub_beta_eff_upper_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_upper_tri(:,:) = 0.0 + allocate( CS%taub_beta_eff_lower_tri(isd:ied,jsd:jed) ) ; CS%taub_beta_eff_lower_tri(:,:) = 0.0 + allocate( CS%OD_rt(isd:ied,jsd:jed) ) ; CS%OD_rt(:,:) = 0.0 + allocate( CS%OD_av(isd:ied,jsd:jed) ) ; CS%OD_av(:,:) = 0.0 + allocate( CS%float_frac(isd:ied,jsd:jed) ) ; CS%float_frac(:,:) = 0.0 + allocate( CS%float_frac_rt(isd:ied,jsd:jed) ) ; CS%float_frac_rt(:,:) = 0.0 if (CS%calve_to_mask) then - allocate ( CS%calve_mask (isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 + allocate( CS%calve_mask(isd:ied,jsd:jed) ) ; CS%calve_mask(:,:) = 0.0 endif endif @@ -1662,19 +1662,19 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (new_sim) then ! new simulation, initialize ice thickness as in the static case - call initialize_ice_thickness (CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed do i=G%isd,G%ied - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then + if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice endif enddo enddo if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) endif endif @@ -1699,12 +1699,12 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (new_sim .and. (.not. (CS%override_shelf_movement .and. CS%mass_from_file))) then ! This model is initialized internally or from a file. - call initialize_ice_thickness (CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) + call initialize_ice_thickness(CS%h_shelf, CS%area_shelf_h, CS%hmask, G, param_file) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed do i=G%isd,G%ied - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then + if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then CS%mass_shelf(i,j) = CS%h_shelf(i,j)*CS%density_ice endif enddo @@ -1729,26 +1729,26 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (.not. G%symmetric) then do j=G%jsd,G%jed do i=G%isd,G%ied - if (((i+G%idg_offset) .eq. (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j).eq.3)) then - CS%u_shelf (i-1,j-1) = CS%u_boundary_values (i-1,j-1) - CS%u_shelf (i-1,j) = CS%u_boundary_values (i-1,j) + if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_boundary_values(i-1,j-1) + CS%u_shelf(i-1,j) = CS%u_boundary_values(i-1,j) endif - if (((j+G%jdg_offset) .eq. (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1).eq.3)) then - CS%u_shelf (i-1,j-1) = CS%u_boundary_values (i-1,j-1) - CS%u_shelf (i,j-1) = CS%u_boundary_values (i,j-1) + if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = CS%u_boundary_values(i-1,j-1) + CS%u_shelf(i,j-1) = CS%u_boundary_values(i,j-1) endif enddo enddo endif - call pass_var (CS%OD_av,G%domain) - call pass_var (CS%float_frac,G%domain) - call pass_var (CS%ice_visc_bilinear,G%domain) - call pass_var (CS%taub_beta_eff_bilinear,G%domain) + call pass_var(CS%OD_av,G%domain) + call pass_var(CS%float_frac,G%domain) + call pass_var(CS%ice_visc_bilinear,G%domain) + call pass_var(CS%taub_beta_eff_bilinear,G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var (CS%area_shelf_h,G%domain) - call pass_var (CS%h_shelf,G%domain) - call pass_var (CS%hmask,G%domain) + call pass_var(CS%area_shelf_h,G%domain) + call pass_var(CS%h_shelf,G%domain) + call pass_var(CS%hmask,G%domain) if (is_root_pe()) PRINT *, "RESTORING ICE SHELF FROM FILE!!!!!!!!!!!!!" endif @@ -1766,7 +1766,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl call cpu_clock_begin(id_clock_pass) call pass_var(G%bathyT, G%domain) call pass_var(CS%hmask, G%domain) - call update_velocity_masks (CS) + call update_velocity_masks(CS) call cpu_clock_end(id_clock_pass) endif @@ -1787,7 +1787,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl enddo ; enddo if (CS%DEBUG) then - call hchksum (fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) + call hchksum(fluxes%frac_shelf_h, "IS init: frac_shelf_h", G%HI, haloshift=0) endif if (present(forces) .and. .not. CS%solo_ice_sheet) then @@ -1847,11 +1847,11 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl enddo enddo - call pass_var (CS%calve_mask,G%domain) + call pass_var(CS%calve_mask,G%domain) endif if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then -! call init_boundary_values (CS, time, CS%input_flux, CS%input_thickness, new_sim) +! call init_boundary_values(CS, time, CS%input_flux, CS%input_thickness, new_sim) if (.not. CS%isthermo) then CS%lprec(:,:) = 0.0 @@ -1860,8 +1860,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces, fl if (new_sim) then if (is_root_pe()) print *,"NEW SIM: initialize velocity" - call update_OD_ffrac_uncoupled (CS) - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters, Time) + call update_OD_ffrac_uncoupled(CS) + call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, 1, iters, Time) ! write (procnum,'(I2)') mpp_pe() @@ -2075,7 +2075,7 @@ subroutine update_shelf_mass(G, CS, Time, fluxes) ! CS%hmask, CS%grid, CS%user_CS, Time, .true.) if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) endif call pass_var(CS%area_shelf_h, G%domain) @@ -2097,7 +2097,7 @@ subroutine update_shelf_mass(G, CS, Time, fluxes) end subroutine update_shelf_mass -subroutine initialize_diagnostic_fields (CS, FE, Time) +subroutine initialize_diagnostic_fields(CS, FE, Time) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure integer :: FE type(time_type), intent(in) :: Time @@ -2119,19 +2119,19 @@ subroutine initialize_diagnostic_fields (CS, FE, Time) do j=jsd,jed do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf (i,j) - if (OD.ge.0) then + OD = G%bathyT(i,j) - rhoi/rhow * h_shelf(i,j) + if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating - OD_av (i,j) = OD + OD_av(i,j) = OD float_frac(i,j) = 0. else - OD_av (i,j) = 0. + OD_av(i,j) = 0. float_frac(i,j) = 1. endif enddo enddo - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, FE, iters, dummy_time) + call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, FE, iters, dummy_time) end subroutine initialize_diagnostic_fields @@ -2200,10 +2200,10 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) ! ###Perhaps flux_enter should be changed into u-face and v-face ! ###fluxes, which can then be used in halo updates, etc. ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED @@ -2231,50 +2231,50 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter (:,:,:) = 0.0 + flux_enter(:,:,:) = 0.0 - h_after_uflux (:,:) = 0.0 - h_after_vflux (:,:) = 0.0 + h_after_uflux(:,:) = 0.0 + h_after_vflux(:,:) = 0.0 ! if (is_root_pe()) write(*,*) "ice_shelf_advect called" do j=jsd,jed do i=isd,ied thick_bd = CS%thickness_boundary_values(i,j) - if (thick_bd .ne. 0.0) then + if (thick_bd /= 0.0) then CS%h_shelf(i,j) = CS%thickness_boundary_values(i,j) endif enddo enddo - call ice_shelf_advect_thickness_x (CS, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) + call ice_shelf_advect_thickness_x(CS, time_step/spy, CS%h_shelf, h_after_uflux, flux_enter) ! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var (h_after_uflux, G%domain) + ! call pass_var(h_after_uflux, G%domain) ! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_thickness_y (CS, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) + call ice_shelf_advect_thickness_y(CS, time_step/spy, h_after_uflux, h_after_vflux, flux_enter) ! call enable_averaging(time_step,Time,CS%diag) -! call pass_var (h_after_vflux, G%domain) +! call pass_var(h_after_vflux, G%domain) ! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) do j=jsd,jed do i=isd,ied - if (CS%hmask(i,j) .eq. 1) then - CS%h_shelf (i,j) = h_after_vflux(i,j) + if (CS%hmask(i,j) == 1) then + CS%h_shelf(i,j) = h_after_vflux(i,j) endif enddo enddo if (CS%moving_shelf_front) then - call shelf_advance_front (CS, flux_enter) + call shelf_advance_front(CS, flux_enter) if (CS%min_thickness_simple_calve > 0.0) then - call ice_shelf_min_thickness_calve (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) + call ice_shelf_min_thickness_calve(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask) endif if (CS%calve_to_mask) then - call calve_to_mask (CS, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) + call calve_to_mask(CS, CS%h_shelf, CS%area_shelf_h, CS%hmask, CS%calve_mask) endif endif @@ -2284,11 +2284,11 @@ subroutine ice_shelf_advect(CS, time_step, melt_rate, Time) !call change_thickness_using_melt(CS,G,time_step, fluxes) - call update_velocity_masks (CS) + call update_velocity_masks(CS) end subroutine ice_shelf_advect -subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) +subroutine ice_shelf_solve_outer(CS, u, v, FE, iters, time) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v integer, intent(in) :: FE @@ -2304,8 +2304,8 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) real :: err_max, err_tempu, err_tempv, err_init, area, max_vel, tempu, tempv, rhoi, rhow real, pointer, dimension(:,:,:,:) :: Phi real, pointer, dimension(:,:,:,:,:,:) :: Phisub - real, dimension (8,4) :: Phi_temp - real, dimension (2,2) :: X,Y + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y character(2) :: iternum character(2) :: procnum, numproc @@ -2317,18 +2317,18 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed rhoi = CS%density_ice rhow = CS%density_ocean_avg - allocate(TAUDX (isdq:iedq,jsdq:jedq) ) ; TAUDX(:,:)=0 - allocate(TAUDY (isdq:iedq,jsdq:jedq) ) ; TAUDY(:,:)=0 - allocate(u_prev_iterate (isdq:iedq,jsdq:jedq) ) - allocate(v_prev_iterate (isdq:iedq,jsdq:jedq) ) - allocate(u_bdry_cont (isdq:iedq,jsdq:jedq) ) ; u_bdry_cont(:,:)=0 - allocate(v_bdry_cont (isdq:iedq,jsdq:jedq) ) ; v_bdry_cont(:,:)=0 - allocate(Au (isdq:iedq,jsdq:jedq) ) ; Au(:,:)=0 - allocate(Av (isdq:iedq,jsdq:jedq) ) ; Av(:,:)=0 - allocate(err_u (isdq:iedq,jsdq:jedq) ) - allocate(err_v (isdq:iedq,jsdq:jedq) ) - allocate(u_last (isdq:iedq,jsdq:jedq) ) - allocate(v_last (isdq:iedq,jsdq:jedq) ) + allocate(TAUDX(isdq:iedq,jsdq:jedq) ) ; TAUDX(:,:)=0 + allocate(TAUDY(isdq:iedq,jsdq:jedq) ) ; TAUDY(:,:)=0 + allocate(u_prev_iterate(isdq:iedq,jsdq:jedq) ) + allocate(v_prev_iterate(isdq:iedq,jsdq:jedq) ) + allocate(u_bdry_cont(isdq:iedq,jsdq:jedq) ) ; u_bdry_cont(:,:)=0 + allocate(v_bdry_cont(isdq:iedq,jsdq:jedq) ) ; v_bdry_cont(:,:)=0 + allocate(Au(isdq:iedq,jsdq:jedq) ) ; Au(:,:)=0 + allocate(Av(isdq:iedq,jsdq:jedq) ) ; Av(:,:)=0 + allocate(err_u(isdq:iedq,jsdq:jedq) ) + allocate(err_v(isdq:iedq,jsdq:jedq) ) + allocate(u_last(isdq:iedq,jsdq:jedq) ) + allocate(v_last(isdq:iedq,jsdq:jedq) ) ! need to make these conditional on GL interpolation allocate(float_cond (G%isd:G%ied,G%jsd:G%jed)) ; float_cond(:,:)=0 @@ -2353,7 +2353,7 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) jsumstart = JSUMSTART_INT_ endif - call calc_shelf_driving_stress (CS, TAUDX, TAUDY, CS%OD_av, FE) + call calc_shelf_driving_stress(CS, TAUDX, TAUDY, CS%OD_av, FE) ! this is to determine which cells contain the grounding line, ! the criterion being that the cell is ice-covered, with some nodes @@ -2365,7 +2365,7 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) if (CS%GL_regularize) then - call interpolate_H_to_B (CS, CS%h_shelf, CS%hmask, H_node) + call interpolate_H_to_B(CS, CS%h_shelf, CS%hmask, H_node) call savearray2 ("H_node",H_node,CS%write_output_to_file) do j=G%jsc,G%jec @@ -2373,24 +2373,24 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) nodefloat = 0 do k=0,1 do l=0,1 - if ((CS%hmask(i,j) .eq. 1) .and. & - (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) .le. 0)) then + if ((CS%hmask(i,j) == 1) .and. & + (rhoi/rhow * H_node(i-1+k,j-1+l) - G%bathyT(i,j) <= 0)) then nodefloat = nodefloat + 1 endif enddo enddo - if ((nodefloat .gt. 0) .and. (nodefloat .lt. 4)) then + if ((nodefloat > 0) .and. (nodefloat < 4)) then !print *,"nodefloat",nodefloat - float_cond (i,j) = 1.0 - CS%float_frac (i,j) = 1.0 + float_cond(i,j) = 1.0 + CS%float_frac(i,j) = 1.0 endif enddo enddo call savearray2 ("float_cond",float_cond,CS%write_output_to_file) - call pass_var (float_cond, G%Domain) + call pass_var(float_cond, G%Domain) - call bilinear_shape_functions_subgrid (Phisub, nsub) + call bilinear_shape_functions_subgrid(Phisub, nsub) call savearray2("Phisub1111",Phisub(:,:,1,1,1,1),CS%write_output_to_file) @@ -2398,21 +2398,21 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) ! make above conditional - u_prev_iterate (:,:) = u(:,:) - v_prev_iterate (:,:) = v(:,:) + u_prev_iterate(:,:) = u(:,:) + v_prev_iterate(:,:) = v(:,:) isym=0 ! must prepare phi - if (FE .eq. 1) then - allocate (Phi (isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 + if (FE == 1) then + allocate(Phi(isd:ied,jsd:jed,1:8,1:4)) ; Phi(:,:,:,:)=0 do j=jsd,jed do i=isd,ied - if (((i .gt. isd) .and. (j .gt. jsd)) .or. (isym .eq. 1)) then - X(:,:) = geolonq (i-1:i,j-1:j)*1000 - Y(:,:) = geolatq (i-1:i,j-1:j)*1000 + if (((i > isd) .and. (j > jsd)) .or. (isym == 1)) then + X(:,:) = geolonq(i-1:i,j-1:j)*1000 + Y(:,:) = geolatq(i-1:i,j-1:j)*1000 else X(2,:) = geolonq(i,j)*1000 X(1,:) = geolonq(i,j)*1000-G%dxT(i,j) @@ -2420,55 +2420,55 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) Y(:,1) = geolatq(i,j)*1000-G%dyT(i,j) endif - call bilinear_shape_functions (X, Y, Phi_temp, area) - Phi (i,j,:,:) = Phi_temp + call bilinear_shape_functions(X, Y, Phi_temp, area) + Phi(i,j,:,:) = Phi_temp enddo enddo endif - if (FE .eq. 1) then - call calc_shelf_visc_bilinear (CS, u, v) + if (FE == 1) then + call calc_shelf_visc_bilinear(CS, u, v) - call pass_var (CS%ice_visc_bilinear, G%domain) - call pass_var (CS%taub_beta_eff_bilinear, G%domain) + call pass_var(CS%ice_visc_bilinear, G%domain) + call pass_var(CS%taub_beta_eff_bilinear, G%domain) else - call calc_shelf_visc_triangular (CS,u,v) + call calc_shelf_visc_triangular(CS,u,v) - call pass_var (CS%ice_visc_upper_tri, G%domain) - call pass_var (CS%taub_beta_eff_upper_tri, G%domain) - call pass_var (CS%ice_visc_lower_tri, G%domain) - call pass_var (CS%taub_beta_eff_lower_tri, G%domain) + call pass_var(CS%ice_visc_upper_tri, G%domain) + call pass_var(CS%taub_beta_eff_upper_tri, G%domain) + call pass_var(CS%ice_visc_lower_tri, G%domain) + call pass_var(CS%taub_beta_eff_lower_tri, G%domain) endif ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed do i=G%isd,G%ied - if (FE .eq. 1) then - CS%taub_beta_eff_bilinear (i,j) = CS%taub_beta_eff_bilinear (i,j) * CS%float_frac (i,j) + if (FE == 1) then + CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) else - CS%taub_beta_eff_upper_tri (i,j) = CS%taub_beta_eff_upper_tri (i,j) * CS%float_frac (i,j) - CS%taub_beta_eff_lower_tri (i,j) = CS%taub_beta_eff_lower_tri (i,j) * CS%float_frac (i,j) + CS%taub_beta_eff_upper_tri(i,j) = CS%taub_beta_eff_upper_tri(i,j) * CS%float_frac(i,j) + CS%taub_beta_eff_lower_tri(i,j) = CS%taub_beta_eff_lower_tri(i,j) * CS%float_frac(i,j) endif enddo enddo - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & + if (FE == 1) then + call apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, & rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, u_bdry_cont, v_bdry_cont) + elseif (FE == 2) then + call apply_boundary_values_triangle(CS, time, u_bdry_cont, v_bdry_cont) endif Au(:,:) = 0.0 ; Av(:,:) = 0.0 - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & + if (FE == 1) then + call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, & G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & + elseif (FE == 2) then + call CG_action_triangular(Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) endif @@ -2479,19 +2479,19 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) err_init = 0 ; err_tempu = 0; err_tempv = 0 do j=jsumstart,G%jecB do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then + if (CS%umask(i,j) == 1) then err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) endif - if (CS%vmask(i,j) .eq. 1) then + if (CS%vmask(i,j) == 1) then err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) endif - if (err_tempv .ge. err_init) then + if (err_tempv >= err_init) then err_init = err_tempv endif enddo enddo - call mpp_max (err_init) + call mpp_max(err_init) if (is_root_pe()) print *,"INITIAL nonlinear residual: ",err_init @@ -2502,30 +2502,30 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) do iter=1,100 - call ice_shelf_solve_inner (CS, u, v, TAUDX, TAUDY, H_node, float_cond, & + call ice_shelf_solve_inner(CS, u, v, TAUDX, TAUDY, H_node, float_cond, & FE, conv_flag, iters, time, Phi, Phisub) if (CS%DEBUG) then - call qchksum (u, "u shelf", G%HI, haloshift=2) - call qchksum (v, "v shelf", G%HI, haloshift=2) + call qchksum(u, "u shelf", G%HI, haloshift=2) + call qchksum(v, "v shelf", G%HI, haloshift=2) endif if (is_root_pe()) print *,"linear solve done",iters," iterations" - if (FE .eq. 1) then - call calc_shelf_visc_bilinear (CS,u,v) - call pass_var (CS%ice_visc_bilinear, G%domain) - call pass_var (CS%taub_beta_eff_bilinear, G%domain) + if (FE == 1) then + call calc_shelf_visc_bilinear(CS,u,v) + call pass_var(CS%ice_visc_bilinear, G%domain) + call pass_var(CS%taub_beta_eff_bilinear, G%domain) else - call calc_shelf_visc_triangular (CS,u,v) - call pass_var (CS%ice_visc_upper_tri, G%domain) - call pass_var (CS%taub_beta_eff_upper_tri, G%domain) - call pass_var (CS%ice_visc_lower_tri, G%domain) - call pass_var (CS%taub_beta_eff_lower_tri, G%domain) + call calc_shelf_visc_triangular(CS,u,v) + call pass_var(CS%ice_visc_upper_tri, G%domain) + call pass_var(CS%taub_beta_eff_upper_tri, G%domain) + call pass_var(CS%ice_visc_lower_tri, G%domain) + call pass_var(CS%taub_beta_eff_lower_tri, G%domain) endif - if (iter .eq. 1) then + if (iter == 1) then ! call savearray2 ("visc1",CS%ice_visc_bilinear,CS%write_output_to_file) endif @@ -2533,91 +2533,91 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) do j=G%jsd,G%jed do i=G%isd,G%ied - if (FE .eq. 1) then - CS%taub_beta_eff_bilinear (i,j) = CS%taub_beta_eff_bilinear (i,j) * CS%float_frac (i,j) + if (FE == 1) then + CS%taub_beta_eff_bilinear(i,j) = CS%taub_beta_eff_bilinear(i,j) * CS%float_frac(i,j) else - CS%taub_beta_eff_upper_tri (i,j) = CS%taub_beta_eff_upper_tri (i,j) * CS%float_frac (i,j) - CS%taub_beta_eff_lower_tri (i,j) = CS%taub_beta_eff_lower_tri (i,j) * CS%float_frac (i,j) + CS%taub_beta_eff_upper_tri(i,j) = CS%taub_beta_eff_upper_tri(i,j) * CS%float_frac(i,j) + CS%taub_beta_eff_lower_tri(i,j) = CS%taub_beta_eff_lower_tri(i,j) * CS%float_frac(i,j) endif enddo enddo - u_bdry_cont (:,:) = 0 ; v_bdry_cont (:,:) = 0 + u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & + if (FE == 1) then + call apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, & rhoi/rhow, u_bdry_cont, v_bdry_cont) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, u_bdry_cont, v_bdry_cont) + elseif (FE == 2) then + call apply_boundary_values_triangle(CS, time, u_bdry_cont, v_bdry_cont) endif Au(:,:) = 0 ; Av(:,:) = 0 - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & + if (FE == 1) then + call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, CS%umask, CS%vmask, CS%hmask, H_node, & CS%ice_visc_bilinear, float_cond, G%bathyT, CS%taub_beta_eff_bilinear, G%areaT, G%isc-1, & G%iec+1, G%jsc-1, G%jec+1, rhoi/rhow) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & + elseif (FE == 2) then + call CG_action_triangular(Au, Av, u, v, CS%umask, CS%vmask, CS%hmask, CS%ice_visc_upper_tri, & CS%ice_visc_lower_tri, CS%taub_beta_eff_upper_tri, CS%taub_beta_eff_lower_tri, & G%dxT, G%dyT, G%areaT, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, isym) endif err_max = 0 - if (CS%nonlin_solve_err_mode .eq. 1) then + if (CS%nonlin_solve_err_mode == 1) then do j=jsumstart,G%jecB do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then + if (CS%umask(i,j) == 1) then err_tempu = ABS (Au(i,j) + u_bdry_cont(i,j) - TAUDX(i,j)) endif - if (CS%vmask(i,j) .eq. 1) then + if (CS%vmask(i,j) == 1) then err_tempv = MAX(ABS (Av(i,j) + v_bdry_cont(i,j) - TAUDY(i,j)), err_tempu) endif - if (err_tempv .ge. err_max) then + if (err_tempv >= err_max) then err_max = err_tempv endif enddo enddo - call mpp_max (err_max) + call mpp_max(err_max) - elseif (CS%nonlin_solve_err_mode .eq. 2) then + elseif (CS%nonlin_solve_err_mode == 2) then max_vel = 0 ; tempu = 0 ; tempv = 0 do j=jsumstart,G%jecB do i=isumstart,G%iecB - if (CS%umask(i,j) .eq. 1) then + if (CS%umask(i,j) == 1) then err_tempu = ABS (u_last(i,j)-u(i,j)) tempu = u(i,j) endif - if (CS%vmask(i,j) .eq. 1) then + if (CS%vmask(i,j) == 1) then err_tempv = MAX(ABS (v_last(i,j)- v(i,j)), err_tempu) tempv = SQRT(v(i,j)**2+tempu**2) endif - if (err_tempv .ge. err_max) then + if (err_tempv >= err_max) then err_max = err_tempv endif - if (tempv .ge. max_vel) then + if (tempv >= max_vel) then max_vel = tempv endif enddo enddo - u_last (:,:) = u(:,:) - v_last (:,:) = v(:,:) + u_last(:,:) = u(:,:) + v_last(:,:) = v(:,:) - call mpp_max (max_vel) - call mpp_max (err_max) + call mpp_max(max_vel) + call mpp_max(err_max) err_init = max_vel endif if (is_root_pe()) print *,"nonlinear residual: ",err_max/err_init - if (err_max .le. CS%nonlinear_tolerance * err_init) then + if (err_max <= CS%nonlinear_tolerance * err_init) then if (is_root_pe()) & print *,"exiting nonlinear solve after ",iter," iterations" exit @@ -2628,25 +2628,25 @@ subroutine ice_shelf_solve_outer (CS, u, v, FE, iters, time) !write (procnum,'(I1)') mpp_pe() !write (numproc,'(I1)') mpp_npes() - deallocate (TAUDX) - deallocate (TAUDY) - deallocate (u_prev_iterate) - deallocate (v_prev_iterate) - deallocate (u_bdry_cont) - deallocate (v_bdry_cont) - deallocate (Au) - deallocate (Av) - deallocate (err_u) - deallocate (err_v) - deallocate (u_last) - deallocate (v_last) - deallocate (H_node) - deallocate (float_cond) - deallocate (Phisub) + deallocate(TAUDX) + deallocate(TAUDY) + deallocate(u_prev_iterate) + deallocate(v_prev_iterate) + deallocate(u_bdry_cont) + deallocate(v_bdry_cont) + deallocate(Au) + deallocate(Av) + deallocate(err_u) + deallocate(err_v) + deallocate(u_last) + deallocate(v_last) + deallocate(H_node) + deallocate(float_cond) + deallocate(Phisub) end subroutine ice_shelf_solve_outer -subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE, conv_flag, iters, time, Phi, Phisub) +subroutine ice_shelf_solve_inner(CS, u, v, taudx, taudy, H_node, float_cond, FE, conv_flag, iters, time, Phi, Phisub) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: taudx, taudy, H_node @@ -2655,7 +2655,7 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE integer, intent(out) :: conv_flag, iters type(time_type) :: time real, pointer, dimension(:,:,:,:) :: Phi - real, dimension (:,:,:,:,:,:),pointer :: Phisub + real, dimension(:,:,:,:,:,:),pointer :: Phisub ! one linear solve (nonlinear iteration) of the solution for velocity @@ -2682,8 +2682,8 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE character(1) :: procnum character(2) :: gridsize - real, dimension (8,4) :: Phi_temp - real, dimension (2,2) :: X,Y + real, dimension(8,4) :: Phi_temp + real, dimension(2,2) :: X,Y hmask => CS%hmask umask => CS%umask @@ -2702,8 +2702,8 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 - Ru(:,:) = 0 ; Rv (:,:) = 0 ; Au (:,:) = 0 ; Av (:,:) = 0 - Du(:,:) = 0 ; Dv (:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 + Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 dot_p1 = 0 ; dot_p2 = 0 ! if (G%symmetric) then @@ -2730,21 +2730,21 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE jsumstart = JSUMSTART_INT_ endif - if (FE .eq. 1) then + if (FE == 1) then visc => CS%ice_visc_bilinear beta => CS%taub_beta_eff_bilinear - elseif (FE .eq. 2) then + elseif (FE == 2) then visc => CS%ice_visc_upper_tri visc_lo => CS%ice_visc_lower_tri beta => CS%taub_beta_eff_upper_tri beta_lo => CS%taub_beta_eff_lower_tri endif - if (FE .eq. 1) then - call apply_boundary_values_bilinear (CS, time, Phisub, H_node, float_cond, & + if (FE == 1) then + call apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, & CS%density_ice/CS%density_ocean_avg, ubd, vbd) - elseif (FE .eq. 2) then - call apply_boundary_values_triangle (CS, time, ubd, vbd) + elseif (FE == 2) then + call apply_boundary_values_triangle(CS, time, ubd, vbd) endif RHSu(:,:) = taudx(:,:) - ubd(:,:) @@ -2754,12 +2754,12 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) - if (FE .eq. 1) then + if (FE == 1) then call matrix_diagonal_bilinear(CS, float_cond, H_node, & CS%density_ice/CS%density_ocean_avg, Phisub, DIAGu, DIAGv) ! DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 - elseif (FE .eq. 2) then - call matrix_diagonal_triangle (CS, DIAGu, DIAGv) + elseif (FE == 2) then + call matrix_diagonal_triangle(CS, DIAGu, DIAGv) DIAGu(:,:) = 1 ; DIAGv(:,:) = 1 endif @@ -2767,12 +2767,12 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE - if (FE .eq. 1) then - call CG_action_bilinear (Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & + if (FE == 1) then + call CG_action_bilinear(Au, Av, u, v, Phi, Phisub, umask, vmask, hmask, & H_node, visc, float_cond, G%bathyT, beta, G%areaT, isc-1, iec+1, jsc-1, & jec+1, CS%density_ice/CS%density_ocean_avg) - elseif (FE .eq. 2) then - call CG_action_triangular (Au, Av, u, v, umask, vmask, hmask, visc, visc_lo, & + elseif (FE == 2) then + call CG_action_triangular(Au, Av, u, v, umask, vmask, hmask, visc, visc_lo, & beta, beta_lo, G%dxT, G%dyT, G%areaT, isc-1, iec+1, jsc-1, jec+1, isym) endif @@ -2784,12 +2784,12 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) .eq. 1) dot_p1 = dot_p1 + Ru(i,j)**2 - if (vmask(i,j) .eq. 1) dot_p1 = dot_p1 + Rv(i,j)**2 + if (umask(i,j) == 1) dot_p1 = dot_p1 + Ru(i,j)**2 + if (vmask(i,j) == 1) dot_p1 = dot_p1 + Rv(i,j)**2 enddo enddo - call mpp_sum (dot_p1) + call mpp_sum(dot_p1) else @@ -2797,12 +2797,12 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=JSUMSTART_INT_,jecq do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + if (umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 enddo enddo - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & + dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & JSUMSTART_INT_, jecq ) endif @@ -2811,8 +2811,8 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsdq,jedq do i=isdq,iedq - if (umask(i,j) .eq. 1) Zu(i,j) = Ru (i,j) / DIAGu (i,j) - if (vmask(i,j) .eq. 1) Zv(i,j) = Rv (i,j) / DIAGv (i,j) + if (umask(i,j) == 1) Zu(i,j) = Ru(i,j) / DIAGu(i,j) + if (vmask(i,j) == 1) Zv(i,j) = Rv(i,j) / DIAGv(i,j) enddo enddo @@ -2843,15 +2843,15 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE Au(:,:) = 0 ; Av(:,:) = 0 - if (FE .eq. 1) then + if (FE == 1) then - call CG_action_bilinear (Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & + call CG_action_bilinear(Au, Av, Du, Dv, Phi, Phisub, umask, vmask, hmask, & H_node, visc, float_cond, G%bathyT, beta, G%areaT, is, ie, js, & je, CS%density_ice/CS%density_ocean_avg) - elseif (FE .eq. 2) then + elseif (FE == 2) then - call CG_action_triangular (Au, Av, Du, Dv, umask, vmask, hmask, visc, visc_lo, & + call CG_action_triangular(Au, Av, Du, Dv, umask, vmask, hmask, visc, visc_lo, & beta, beta_lo, G%dxT, G%dyT, G%areaT, is, ie, js, je, isym) endif @@ -2865,37 +2865,37 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE dot_p1 = 0 ; dot_p2 = 0 do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) .eq. 1) then + if (umask(i,j) == 1) then dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) dot_p2 = dot_p2 + Du(i,j)*Au(i,j) endif - if (vmask(i,j) .eq. 1) then + if (vmask(i,j) == 1) then dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) dot_p2 = dot_p2 + Dv(i,j)*Av(i,j) endif enddo enddo - call mpp_sum (dot_p1) ; call mpp_sum (dot_p2) + call mpp_sum(dot_p1) ; call mpp_sum(dot_p2) else sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq do i=iscq,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + & + if (umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & Zv(i,j) * Rv(i,j) - if (umask(i,j) .eq. 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) - if (vmask(i,j) .eq. 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & + if (umask(i,j) == 1) sum_vec_2(i,j) = Du(i,j) * Au(i,j) + if (vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & Dv(i,j) * Av(i,j) enddo enddo - dot_p1 = reproducing_sum ( sum_vec, iscq, iecq, & + dot_p1 = reproducing_sum( sum_vec, iscq, iecq, & jscq, jecq ) - dot_p2 = reproducing_sum ( sum_vec_2, iscq, iecq, & + dot_p2 = reproducing_sum( sum_vec_2, iscq, iecq, & jscq, jecq ) endif @@ -2910,17 +2910,17 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsd,jed do i=isd,ied - if (umask(i,j) .eq. 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) - if (vmask(i,j) .eq. 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) + if (umask(i,j) == 1) u(i,j) = u(i,j) + alpha_k * Du(i,j) + if (vmask(i,j) == 1) v(i,j) = v(i,j) + alpha_k * Dv(i,j) enddo enddo do j=jsd,jed do i=isd,ied - if (umask(i,j) .eq. 1) then + if (umask(i,j) == 1) then Ru_old(i,j) = Ru(i,j) ; Zu_old(i,j) = Zu(i,j) endif - if (vmask(i,j) .eq. 1) then + if (vmask(i,j) == 1) then Rv_old(i,j) = Rv(i,j) ; Zv_old(i,j) = Zv(i,j) endif enddo @@ -2931,19 +2931,19 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsd,jed do i=isd,ied - if (umask(i,j) .eq. 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) - if (vmask(i,j) .eq. 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) + if (umask(i,j) == 1) Ru(i,j) = Ru(i,j) - alpha_k * Au(i,j) + if (vmask(i,j) == 1) Rv(i,j) = Rv(i,j) - alpha_k * Av(i,j) enddo enddo do j=jsdq,jedq do i=isdq,iedq - if (umask(i,j) .eq. 1) then - Zu(i,j) = Ru (i,j) / DIAGu (i,j) + if (umask(i,j) == 1) then + Zu(i,j) = Ru(i,j) / DIAGu(i,j) endif - if (vmask(i,j) .eq. 1) then - Zv(i,j) = Rv (i,j) / DIAGv (i,j) + if (vmask(i,j) == 1) then + Zv(i,j) = Rv(i,j) / DIAGv(i,j) endif enddo enddo @@ -2956,17 +2956,17 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE dot_p1 = 0 ; dot_p2 = 0 do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) .eq. 1) then + if (umask(i,j) == 1) then dot_p1 = dot_p1 + Zu(i,j)*Ru(i,j) dot_p2 = dot_p2 + Zu_old(i,j)*Ru_old(i,j) endif - if (vmask(i,j) .eq. 1) then + if (vmask(i,j) == 1) then dot_p1 = dot_p1 + Zv(i,j)*Rv(i,j) dot_p2 = dot_p2 + Zv_old(i,j)*Rv_old(i,j) endif enddo enddo - call mpp_sum (dot_p1) ; call mpp_sum (dot_p2) + call mpp_sum(dot_p1) ; call mpp_sum(dot_p2) else @@ -2975,21 +2975,21 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=JSUMSTART_INT_,jecq do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + & + if (umask(i,j) == 1) sum_vec(i,j) = Zu(i,j) * Ru(i,j) + if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + & Zv(i,j) * Rv(i,j) - if (umask(i,j) .eq. 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) - if (vmask(i,j) .eq. 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & + if (umask(i,j) == 1) sum_vec_2(i,j) = Zu_old(i,j) * Ru_old(i,j) + if (vmask(i,j) == 1) sum_vec_2(i,j) = sum_vec_2(i,j) + & Zv_old(i,j) * Rv_old(i,j) enddo enddo - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & + dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & JSUMSTART_INT_, jecq ) - dot_p2 = reproducing_sum ( sum_vec_2, ISUMSTART_INT_, iecq, & + dot_p2 = reproducing_sum( sum_vec_2, ISUMSTART_INT_, iecq, & JSUMSTART_INT_, jecq ) endif @@ -3002,8 +3002,8 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsd,jed do i=isd,ied - if (umask(i,j) .eq. 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) - if (vmask(i,j) .eq. 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) + if (umask(i,j) == 1) Du(i,j) = Zu(i,j) + beta_k * Du(i,j) + if (vmask(i,j) == 1) Dv(i,j) = Zv(i,j) + beta_k * Dv(i,j) enddo enddo @@ -3015,15 +3015,15 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsumstart,jecq do i=isumstart,iecq - if (umask(i,j) .eq. 1) then + if (umask(i,j) == 1) then dot_p1 = dot_p1 + Ru(i,j)**2 endif - if (vmask(i,j) .eq. 1) then + if (vmask(i,j) == 1) then dot_p1 = dot_p1 + Rv(i,j)**2 endif enddo enddo - call mpp_sum (dot_p1) + call mpp_sum(dot_p1) else @@ -3031,12 +3031,12 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=JSUMSTART_INT_,jecq do i=ISUMSTART_INT_,iecq - if (umask(i,j) .eq. 1) sum_vec(i,j) = Ru(i,j)**2 - if (vmask(i,j) .eq. 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 + if (umask(i,j) == 1) sum_vec(i,j) = Ru(i,j)**2 + if (vmask(i,j) == 1) sum_vec(i,j) = sum_vec(i,j) + Rv(i,j)**2 enddo enddo - dot_p1 = reproducing_sum ( sum_vec, ISUMSTART_INT_, iecq, & + dot_p1 = reproducing_sum( sum_vec, ISUMSTART_INT_, iecq, & JSUMSTART_INT_, jecq ) ! if (is_root_pe()) print *, dot_p1 @@ -3050,7 +3050,7 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE ! print *,"|r|",dot_p1 ! endif - if (dot_p1 .le. CS%cg_tolerance * resid0) then + if (dot_p1 <= CS%cg_tolerance * resid0) then iters = iter conv_flag = 1 exit @@ -3058,7 +3058,7 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE cg_halo = cg_halo - 1 - if (cg_halo .eq. 0) then + if (cg_halo == 0) then ! pass vectors call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) call pass_vector(u, v, G%domain, TO_ALL, BGRID_NE) @@ -3070,29 +3070,29 @@ subroutine ice_shelf_solve_inner (CS, u, v, taudx, taudy, H_node, float_cond, FE do j=jsdq,jedq do i=isdq,iedq - if (umask(i,j) .eq. 3) then + if (umask(i,j) == 3) then u(i,j) = u_bdry(i,j) - elseif (umask(i,j) .eq. 0) then + elseif (umask(i,j) == 0) then u(i,j) = 0 endif - if (vmask(i,j) .eq. 3) then + if (vmask(i,j) == 3) then v(i,j) = v_bdry(i,j) - elseif (vmask(i,j) .eq. 0) then + elseif (vmask(i,j) == 0) then v(i,j) = 0 endif enddo enddo - call pass_vector (u,v, G%domain, TO_ALL, BGRID_NE) + call pass_vector(u,v, G%domain, TO_ALL, BGRID_NE) - if (conv_flag .eq. 0) then + if (conv_flag == 0) then iters = CS%cg_max_iterations endif end subroutine ice_shelf_solve_inner -subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_thickness_x(CS, time_step, h0, h_after_uflux, flux_enter) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, intent(in) :: time_step real, dimension(:,:), intent(in) :: h0 @@ -3105,10 +3105,10 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3144,29 +3144,29 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ i_off = G%idg_offset ; j_off = G%jdg_offset do j=jsd+1,jed-1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries stencil(:) = -1 -! if (i+i_off .eq. G%domain%nihalo+G%domain%nihalo) +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) do i=is,ie - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then - if (i+i_off .eq. G%domain%nihalo+1) then + if (i+i_off == G%domain%nihalo+1) then at_west_bdry=.true. else at_west_bdry=.false. endif - if (i+i_off .eq. G%domain%niglobal+G%domain%nihalo) then + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then at_east_bdry=.true. else at_east_bdry=.false. endif - if (hmask(i,j) .eq. 1) then + if (hmask(i,j) == 1) then dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) @@ -3178,29 +3178,29 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ ! 1ST DO LEFT FACE - if (u_face_mask (i-1,j) .eq. 4.) then + if (u_face_mask(i-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i-1,j) / dxdyh + flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i-1,j) / dxdyh else ! get u-velocity at center of left face u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - ! if (at_west_bdry .and. (i .eq. G%isc)) then + ! if (at_west_bdry .and. (i == G%isc)) then ! print *, j, u_face, stencil(-1) ! endif - if (u_face .gt. 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available ! i may not cover all the cases.. but i cover the realistic ones - if (at_west_bdry .AND. (hmask(i-1,j).eq.3)) then ! at western bdry but there is a + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it stencil (-1) = CS%thickness_boundary_values(i-1,j) flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - elseif (hmask(i-1,j) * hmask(i-2,j) .eq. 1) then ! h(i-2) and h(i-1) are valid + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) @@ -3213,8 +3213,8 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ endif - elseif (u_face .lt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) @@ -3222,7 +3222,7 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ else flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) endif endif @@ -3233,22 +3233,22 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ ! get u-velocity at center of right face - if (u_face_mask (i+1,j) .eq. 4.) then + if (u_face_mask(i+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i+1,j) / dxdyh + flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i+1,j) / dxdyh else u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - if (u_face .lt. 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - if (at_east_bdry .AND. (hmask(i+1,j).eq.3)) then ! at eastern bdry but there is a + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - elseif (hmask(i+1,j) * hmask(i+2,j) .eq. 1) then ! h(i+2) and h(i+1) are valid + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & @@ -3262,9 +3262,9 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ endif - elseif (u_face .gt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & @@ -3276,7 +3276,7 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - if ((hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2)) then + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) endif @@ -3288,29 +3288,29 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ endif - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - if (at_west_bdry .AND. (hmask(i-1,j) .EQ. 3)) then + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter (i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i-1,j) - elseif (u_face_mask (i-1,j) .eq. 4.) then - flux_enter (i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values (i-1,j) + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i-1,j) + elseif (u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values(i-1,j) endif - if (at_east_bdry .AND. (hmask(i+1,j) .EQ. 3)) then + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i+1,j) .eq. 4.) then - flux_enter (i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values (i+1,j) + elseif (u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values(i+1,j) endif - if ((i .eq. is) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i-1,j) .eq. 1)) then + if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered hmask(i,j) = 2 - elseif ((i .eq. ie) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i+1,j) .eq. 1)) then + elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered @@ -3333,7 +3333,7 @@ subroutine ice_shelf_advect_thickness_x (CS, time_step, h0, h_after_uflux, flux_ end subroutine ice_shelf_advect_thickness_x -subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_vflux, flux_enter) +subroutine ice_shelf_advect_thickness_y(CS, time_step, h_after_uflux, h_after_vflux, flux_enter) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, intent(in) :: time_step real, dimension(:,:), intent(in) :: h_after_uflux @@ -3346,10 +3346,10 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3384,55 +3384,55 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v i_off = G%idg_offset ; j_off = G%jdg_offset do i=isd+2,ied-2 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries stencil(:) = -1 do j=js,je - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then - if (j+j_off .eq. G%domain%njhalo+1) then + if (j+j_off == G%domain%njhalo+1) then at_south_bdry=.true. else at_south_bdry=.false. endif - if (j+j_off .eq. G%domain%njglobal+G%domain%njhalo) then + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then at_north_bdry=.true. else at_north_bdry=.false. endif - if (hmask(i,j) .eq. 1) then + if (hmask(i,j) == 1) then dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux (i,j) = h_after_uflux (i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) - stencil (:) = h_after_uflux (i,j-2:j+2) ! fine as long has ny_halo >= 2 + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 flux_diff_cell = 0 ! 1ST DO south FACE - if (v_face_mask (i,j-1) .eq. 4.) then + if (v_face_mask(i,j-1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j-1) / dxdyh + flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j-1) / dxdyh else ! get u-velocity at center of left face v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - if (v_face .gt. 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available ! i may not cover all the cases.. but i cover the realistic ones - if (at_south_bdry .AND. (hmask(i,j-1).eq.3)) then ! at western bdry but there is a + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - elseif (hmask(i,j-1) * hmask(i,j-2) .eq. 1) then ! h(j-2) and h(j-1) are valid + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & @@ -3444,16 +3444,16 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) endif - elseif (v_face .lt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) endif @@ -3465,21 +3465,21 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v ! NEXT DO north FACE - if (v_face_mask(i,j+1) .eq. 4.) then + if (v_face_mask(i,j+1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j+1) / dxdyh + flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j+1) / dxdyh else ! get u-velocity at center of right face v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - if (v_face .lt. 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - if (at_north_bdry .AND. (hmask(i,j+1).eq.3)) then ! at eastern bdry but there is a + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) .eq. 1) then ! h(j+2) and h(j+1) are valid + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & (stencil(1) - phi * (stencil(1)-stencil(0))/2) @@ -3489,9 +3489,9 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) endif - elseif (v_face .gt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) @@ -3499,7 +3499,7 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) endif endif @@ -3508,34 +3508,34 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v endif - h_after_vflux (i,j) = h_after_vflux (i,j) + flux_diff_cell + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - if (at_south_bdry .AND. (hmask(i,j-1) .EQ. 3)) then + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then v_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i,j-1)) - flux_enter (i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) .eq. 4.) then - flux_enter (i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j-1) + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j-1) + elseif (v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j-1) endif - if (at_north_bdry .AND. (hmask(i,j+1) .EQ. 3)) then + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%u_shelf(i-1,j) + CS%u_shelf(i,j)) - flux_enter (i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) .eq. 4.) then - flux_enter (i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j+1) + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * CS%thickness_boundary_values(i,j+1) + elseif (v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j+1) endif - if ((j .eq. js) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j-1) .eq. 1)) then + if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered - hmask (i,j) = 2 - elseif ((j .eq. je) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j+1) .eq. 1)) then + hmask(i,j) = 2 + elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered - hmask (i,j) = 2 + hmask(i,j) = 2 endif endif @@ -3548,7 +3548,7 @@ subroutine ice_shelf_advect_thickness_y (CS, time_step, h_after_uflux, h_after_v end subroutine ice_shelf_advect_thickness_y -subroutine shelf_advance_front (CS, flux_enter) +subroutine shelf_advance_front(CS, flux_enter) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(:,:,:), intent(inout) :: flux_enter @@ -3567,10 +3567,10 @@ subroutine shelf_advance_front (CS, flux_enter) ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -3587,7 +3587,7 @@ subroutine shelf_advance_front (CS, flux_enter) real :: h_reference, dxh, dyh, dxdyh, rho, partial_vol, tot_flux integer, dimension(4) :: mapi, mapj, new_partial ! real, dimension(size(flux_enter,1),size(flux_enter,2),size(flux_enter,2)) :: flux_enter_replace - real, dimension (:,:,:), pointer :: flux_enter_replace => NULL() + real, dimension(:,:,:), pointer :: flux_enter_replace => NULL() G => CS%grid h_shelf => CS%h_shelf @@ -3612,37 +3612,37 @@ subroutine shelf_advance_front (CS, flux_enter) mapi(1) = -1 ; mapi(2) = 1 ; mapi(3:4) = 0 mapj(3) = -1 ; mapj(4) = 1 ; mapj(1:2) = 0 - do while (iter_flag .eq. 1) + do while (iter_flag == 1) iter_flag = 0 - if (iter_count .gt. 0) then - flux_enter (:,:,:) = flux_enter_replace(:,:,:) - flux_enter_replace (:,:,:) = 0.0 + if (iter_count > 0) then + flux_enter(:,:,:) = flux_enter_replace(:,:,:) + flux_enter_replace(:,:,:) = 0.0 endif iter_count = iter_count + 1 - ! if iter_count .ge. 3 then some halo updates need to be done... + ! if iter_count >= 3 then some halo updates need to be done... do j=jsc-1,jec+1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then do i=isc-1,iec+1 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 h_reference = 0.0 tot_flux = 0.0 do k=1,2 - if (flux_enter(i,j,k) .gt. 0) then + if (flux_enter(i,j,k) > 0) then n_flux = n_flux + 1 h_reference = h_reference + h_shelf(i+2*k-3,j) tot_flux = tot_flux + flux_enter(i,j,k) @@ -3651,71 +3651,71 @@ subroutine shelf_advance_front (CS, flux_enter) enddo do k=1,2 - if (flux_enter(i,j,k+2) .gt. 0) then + if (flux_enter(i,j,k+2) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + h_shelf (i,j+2*k-3) + h_reference = h_reference + h_shelf(i,j+2*k-3) tot_flux = tot_flux + flux_enter(i,j,k+2) - flux_enter (i,j,k+2) = 0.0 + flux_enter(i,j,k+2) = 0.0 endif enddo - if (n_flux .gt. 0) then + if (n_flux > 0) then dxdyh = G%areaT(i,j) h_reference = h_reference / real(n_flux) - partial_vol = h_shelf (i,j) * area_shelf_h (i,j) + tot_flux + partial_vol = h_shelf(i,j) * area_shelf_h(i,j) + tot_flux - if ((partial_vol / dxdyh) .eq. h_reference) then ! cell is exactly covered, no overflow - hmask (i,j) = 1 - h_shelf (i,j) = h_reference + if ((partial_vol / dxdyh) == h_reference) then ! cell is exactly covered, no overflow + hmask(i,j) = 1 + h_shelf(i,j) = h_reference area_shelf_h(i,j) = dxdyh - elseif ((partial_vol / dxdyh) .lt. h_reference) then - hmask (i,j) = 2 - ! mass_shelf (i,j) = partial_vol * rho - area_shelf_h (i,j) = partial_vol / h_reference - h_shelf (i,j) = h_reference + elseif ((partial_vol / dxdyh) < h_reference) then + hmask(i,j) = 2 + ! mass_shelf(i,j) = partial_vol * rho + area_shelf_h(i,j) = partial_vol / h_reference + h_shelf(i,j) = h_reference else if (.not. associated (flux_enter_replace)) then - allocate ( flux_enter_replace (G%isd:G%ied,G%jsd:G%jed,1:4) ) - flux_enter_replace (:,:,:) = 0.0 + allocate( flux_enter_replace (G%isd:G%ied,G%jsd:G%jed,1:4) ) + flux_enter_replace(:,:,:) = 0.0 endif - hmask (i,j) = 1 + hmask(i,j) = 1 area_shelf_h(i,j) = dxdyh - !h_temp (i,j) = h_reference + !h_temp(i,j) = h_reference partial_vol = partial_vol - h_reference * dxdyh iter_flag = 1 - n_flux = 0 ; new_partial (:) = 0 + n_flux = 0 ; new_partial(:) = 0 do k=1,2 - if (u_face_mask (i-2+k,j) .eq. 2) then + if (u_face_mask(i-2+k,j) == 2) then n_flux = n_flux + 1 - elseif (hmask (i+2*k-3,j) .eq. 0) then + elseif (hmask(i+2*k-3,j) == 0) then n_flux = n_flux + 1 - new_partial (k) = 1 + new_partial(k) = 1 endif enddo do k=1,2 - if (v_face_mask (i,j-2+k) .eq. 2) then + if (v_face_mask(i,j-2+k) == 2) then n_flux = n_flux + 1 - elseif (hmask (i,j+2*k-3) .eq. 0) then + elseif (hmask(i,j+2*k-3) == 0) then n_flux = n_flux + 1 - new_partial (k+2) = 1 + new_partial(k+2) = 1 endif enddo - if (n_flux .eq. 0) then ! there is nowhere to put the extra ice! + if (n_flux == 0) then ! there is nowhere to put the extra ice! h_shelf(i,j) = h_reference + partial_vol / dxdyh else h_shelf(i,j) = h_reference do k=1,2 - if (new_partial(k) .eq. 1) & - flux_enter_replace (i+2*k-3,j,3-k) = partial_vol / real(n_flux) + if (new_partial(k) == 1) & + flux_enter_replace(i+2*k-3,j,3-k) = partial_vol / real(n_flux) enddo do k=1,2 ! ### Combine these two loops? - if (new_partial(k+2) .eq. 1) & + if (new_partial(k+2) == 1) & flux_enter_replace(i,j+2*k-3,5-k) = partial_vol / real(n_flux) enddo endif @@ -3734,14 +3734,14 @@ subroutine shelf_advance_front (CS, flux_enter) call mpp_max(iter_count) - if(is_root_pe() .and. (iter_count.gt.1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" + if (is_root_pe() .and. (iter_count > 1)) print *, iter_count, "MAX ITERATIONS,ADVANCE FRONT" if (associated(flux_enter_replace)) deallocate(flux_enter_replace) end subroutine shelf_advance_front !> Apply a very simple calving law using a minimum thickness rule -subroutine ice_shelf_min_thickness_calve (CS, h_shelf, area_shelf_h,hmask) +subroutine ice_shelf_min_thickness_calve(CS, h_shelf, area_shelf_h,hmask) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask type(ocean_grid_type), pointer :: G @@ -3751,9 +3751,9 @@ subroutine ice_shelf_min_thickness_calve (CS, h_shelf, area_shelf_h,hmask) do j=G%jsd,G%jed do i=G%isd,G%ied -! if ((h_shelf(i,j) .lt. CS%min_thickness_simple_calve) .and. (hmask(i,j).eq.1) .and. & -! (CS%float_frac(i,j) .eq. 0.0)) then - if ((h_shelf(i,j) .lt. CS%min_thickness_simple_calve) .and. (area_shelf_h(i,j).gt. 0.)) then +! if ((h_shelf(i,j) < CS%min_thickness_simple_calve) .and. (hmask(i,j) == 1) .and. & +! (CS%float_frac(i,j) == 0.0)) then + if ((h_shelf(i,j) < CS%min_thickness_simple_calve) .and. (area_shelf_h(i,j) > 0.)) then h_shelf(i,j) = 0.0 area_shelf_h(i,j) = 0.0 hmask(i,j) = 0.0 @@ -3763,7 +3763,7 @@ subroutine ice_shelf_min_thickness_calve (CS, h_shelf, area_shelf_h,hmask) end subroutine ice_shelf_min_thickness_calve -subroutine calve_to_mask (CS, h_shelf, area_shelf_h, hmask, calve_mask) +subroutine calve_to_mask(CS, h_shelf, area_shelf_h, hmask, calve_mask) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(:,:), intent(inout) :: h_shelf, area_shelf_h, hmask, calve_mask @@ -3775,7 +3775,7 @@ subroutine calve_to_mask (CS, h_shelf, area_shelf_h, hmask, calve_mask) if (CS%calve_to_mask) then do j=G%jsc,G%jec do i=G%isc,G%iec - if ((calve_mask(i,j) .eq. 0.0) .and. (hmask(i,j) .ne. 0.0)) then + if ((calve_mask(i,j) == 0.0) .and. (hmask(i,j) /= 0.0)) then h_shelf(i,j) = 0.0 area_shelf_h(i,j) = 0.0 hmask(i,j) = 0.0 @@ -3786,7 +3786,7 @@ subroutine calve_to_mask (CS, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask -subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) +subroutine calc_shelf_driving_stress(CS, TAUD_X, TAUD_Y, OD, FE) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(:,:), intent(in) :: OD real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: TAUD_X, TAUD_Y @@ -3805,10 +3805,10 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) ! FE : 1 if bilinear, 2 if triangular linear FE - real, dimension (:,:), pointer :: D, & ! ocean floor depth + real, dimension(:,:), pointer :: D, & ! ocean floor depth H, & ! ice shelf thickness hmask, u_face_mask, v_face_mask, float_frac - real, dimension (SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation BASE ! basal elevation of shelf/stream character(1) :: procnum @@ -3874,35 +3874,35 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) dxdyh = G%areaT(i,j) ! print *,dxh," ",dyh," ",dxdyh - if (hmask(i,j) .eq. 1) then ! we are inside the global computational bdry, at an ice-filled cell + if (hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx - if ((i+i_off) .eq. gisc) then ! at left computational bdry - if (hmask(i+1,j) .eq. 1) then + if ((i+i_off) == gisc) then ! at left computational bdry + if (hmask(i+1,j) == 1) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 endif - elseif ((i+i_off) .eq. giec) then ! at right computational bdry - if (hmask(i-1,j) .eq. 1) then + elseif ((i+i_off) == giec) then ! at right computational bdry + if (hmask(i-1,j) == 1) then sx = (S(i,j)-S(i-1,j))/dxh else sx=0 endif else ! interior - if (hmask(i+1,j) .eq. 1) then + if (hmask(i+1,j) == 1) then cnt = cnt+1 sx = S(i+1,j) else sx = S(i,j) endif - if (hmask(i-1,j) .eq. 1) then + if (hmask(i-1,j) == 1) then cnt = cnt+1 sx = sx - S(i-1,j) else sx = sx - S(i,j) endif - if (cnt .eq. 0) then + if (cnt == 0) then sx=0 else sx = sx / (cnt * dxh) @@ -3912,32 +3912,32 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) cnt = 0 ! calculate sy, similarly - if ((j+j_off) .eq. gjsc) then ! at south computational bdry - if (hmask(i,j+1) .eq. 1) then + if ((j+j_off) == gjsc) then ! at south computational bdry + if (hmask(i,j+1) == 1) then sy = (S(i,j+1)-S(i,j))/dyh else sy = 0 endif - elseif ((j+j_off) .eq. gjec) then ! at nprth computational bdry - if (hmask(i,j-1) .eq. 1) then + elseif ((j+j_off) == gjec) then ! at nprth computational bdry + if (hmask(i,j-1) == 1) then sy = (S(i,j)-S(i,j-1))/dyh else sy = 0 endif else ! interior - if (hmask(i,j+1) .eq. 1) then + if (hmask(i,j+1) == 1) then cnt = cnt+1 sy = S(i,j+1) else sy = S(i,j) endif - if (hmask(i,j-1) .eq. 1) then + if (hmask(i,j-1) == 1) then cnt = cnt+1 sy = sy - S(i,j-1) else sy = sy - S(i,j) endif - if (cnt .eq. 0) then + if (cnt == 0) then sy=0 else sy = sy / (cnt * dyh) @@ -3945,10 +3945,10 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) endif - if (FE .eq. 1) then + if (FE == 1) then ! SW vertex - taud_x (i-1,j-1) = taud_x (i-1,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh + taud_x(i-1,j-1) = taud_x(i-1,j-1) - .25 * rho * grav * H(i,j) * sx * dxdyh taud_y(i-1,j-1) = taud_y(i-1,j-1) - .25 * rho * grav * H(i,j) * sy * dxdyh ! SE vertex @@ -3984,14 +3984,14 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) endif - if (float_frac(i,j) .eq. 1) then - neumann_val = .5 * grav * (rho * H (i,j) ** 2 - rhow * D(i,j) ** 2) + if (float_frac(i,j) == 1) then + neumann_val = .5 * grav * (rho * H(i,j) ** 2 - rhow * D(i,j) ** 2) else neumann_val = .5 * grav * (1-rho/rhow) * rho * H(i,j) ** 2 endif - if ((u_face_mask(i-1,j) .eq. 2) .OR. (hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2) ) then + if ((u_face_mask(i-1,j) == 2) .OR. (hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2) ) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -4005,19 +4005,19 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) taud_x(i-1,j) = taud_x(i-1,j) - .5 * dyh * neumann_val endif - if ((u_face_mask(i,j) .eq. 2) .OR. (hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2) ) then + if ((u_face_mask(i,j) == 2) .OR. (hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2) ) then ! right face of the cell is at a stress boundary taud_x(i,j-1) = taud_x(i,j-1) + .5 * dyh * neumann_val taud_x(i,j) = taud_x(i,j) + .5 * dyh * neumann_val endif - if ((v_face_mask(i,j-1) .eq. 2) .OR. (hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2) ) then + if ((v_face_mask(i,j-1) == 2) .OR. (hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2) ) then ! south face of the cell is at a stress boundary taud_y(i-1,j-1) = taud_y(i-1,j-1) - .5 * dxh * neumann_val taud_y(i,j-1) = taud_y(i,j-1) - .5 * dxh * neumann_val endif - if ((v_face_mask(i,j) .eq. 2) .OR. (hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2) ) then + if ((v_face_mask(i,j) == 2) .OR. (hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2) ) then ! north face of the cell is at a stress boundary taud_y(i-1,j) = taud_y(i-1,j) + .5 * dxh * neumann_val ! note negative sign due to direction of normal vector taud_y(i,j) = taud_y(i,j) + .5 * dxh * neumann_val @@ -4033,7 +4033,7 @@ subroutine calc_shelf_driving_stress (CS, TAUD_X, TAUD_Y, OD, FE) end subroutine calc_shelf_driving_stress -subroutine init_boundary_values (CS, time, input_flux, input_thick, new_sim) +subroutine init_boundary_values(CS, time, input_flux, input_thick, new_sim) type(time_type), intent(in) :: Time type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, intent(in) :: input_flux, input_thick @@ -4047,7 +4047,7 @@ subroutine init_boundary_values (CS, time, input_flux, input_thick, new_sim) ! computational domain -- if this function gets moves to another module, ! DO NOT TAKE THE RESTARTING BIT WITH IT - real, dimension (:,:) , pointer :: thickness_boundary_values, & + real, dimension(:,:) , pointer :: thickness_boundary_values, & u_boundary_values, & v_boundary_values, & u_face_mask, v_face_mask, hmask @@ -4084,20 +4084,20 @@ subroutine init_boundary_values (CS, time, input_flux, input_thick, new_sim) do j=jsd,jed do i=isd,ied -! if ((i .eq. 4) .AND. ((mpp_pe() .eq. 0) .or. (mpp_pe() .eq. 6))) then +! if ((i == 4) .AND. ((mpp_pe() == 0) .or. (mpp_pe() == 6))) then ! print *,hmask(i,j),i,j,mpp_pe() ! endif - if (hmask(i,j) .eq. 3) then - thickness_boundary_values (i,j) = input_thick + if (hmask(i,j) == 3) then + thickness_boundary_values(i,j) = input_thick endif - if ((hmask(i,j) .eq. 0) .or. (hmask(i,j) .eq. 1) .or. (hmask(i,j) .eq. 2)) then - if ((i.le.iec).and.(i.ge.isc)) then - if (u_face_mask (i-1,j) .eq. 3) then - u_boundary_values (i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & + if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then + if ((i <= iec).and.(i >= isc)) then + if (u_face_mask(i-1,j) == 3) then + u_boundary_values(i-1,j-1) = (1 - ((G%geoLatBu(i-1,j-1) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & 1.5 * input_flux / input_thick - u_boundary_values (i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & + u_boundary_values(i-1,j) = (1 - ((G%geoLatBu(i-1,j) - 0.5*CS%len_lat)*2./CS%len_lat)**2) * & 1.5 * input_flux / input_thick endif endif @@ -4105,14 +4105,14 @@ subroutine init_boundary_values (CS, time, input_flux, input_thick, new_sim) if (.not.(new_sim)) then if (.not. G%symmetric) then - if (((i+i_off) .eq. (G%domain%nihalo+1)).and.(u_face_mask(i-1,j).eq.3)) then - CS%u_shelf (i-1,j-1) = u_boundary_values (i-1,j-1) - CS%u_shelf (i-1,j) = u_boundary_values (i-1,j) -! print *, u_boundary_values (i-1,j) + if (((i+i_off) == (G%domain%nihalo+1)).and.(u_face_mask(i-1,j) == 3)) then + CS%u_shelf(i-1,j-1) = u_boundary_values(i-1,j-1) + CS%u_shelf(i-1,j) = u_boundary_values(i-1,j) +! print *, u_boundary_values(i-1,j) endif - if (((j+j_off) .eq. (G%domain%njhalo+1)).and.(v_face_mask(i,j-1).eq.3)) then - CS%u_shelf (i-1,j-1) = u_boundary_values (i-1,j-1) - CS%u_shelf (i,j-1) = u_boundary_values (i,j-1) + if (((j+j_off) == (G%domain%njhalo+1)).and.(v_face_mask(i,j-1) == 3)) then + CS%u_shelf(i-1,j-1) = u_boundary_values(i-1,j-1) + CS%u_shelf(i,j-1) = u_boundary_values(i,j-1) endif endif endif @@ -4124,11 +4124,11 @@ end subroutine init_boundary_values subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper, nu_lower, & beta_upper, beta_lower, dxh, dyh, dxdyh, is, ie, js, je, isym) -real, dimension (:,:), intent (inout) :: uret, vret -real, dimension (:,:), intent (in) :: u, v -real, dimension (:,:), intent (in) :: umask, vmask -real, dimension (:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower -real, dimension (:,:), intent (in) :: dxh, dyh, dxdyh +real, dimension(:,:), intent (inout) :: uret, vret +real, dimension(:,:), intent (in) :: u, v +real, dimension(:,:), intent (in) :: umask, vmask +real, dimension(:,:), intent (in) :: hmask, nu_upper, nu_lower, beta_upper, beta_lower +real, dimension(:,:), intent (in) :: dxh, dyh, dxdyh integer, intent(in) :: is, ie, js, je, isym ! the linear action of the matrix on (u,v) with triangular finite elements @@ -4145,20 +4145,20 @@ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper do i=is,ie do j=js,je - if (hmask(i,j) .eq. 1) then ! this cell's vertices contain degrees of freedom + if (hmask(i,j) == 1) then ! this cell's vertices contain degrees of freedom ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) + .5 * dxdyh(i,j) * nu_lower(i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) + .5 * dxdyh(i,j) * nu_lower(i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) uret(i,j-1) = uret(i,j-1) + & beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & @@ -4169,13 +4169,13 @@ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper v(i-1,j) + v(i,j-1)) endif - if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_lower(i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_lower (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_lower(i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) uret(i,j-1) = uret(i,j-1) + & beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & @@ -4186,13 +4186,13 @@ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper v(i-1,j) + v(i,j-1)) endif - if (umask(i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node + if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node uret(i-1,j-1) = uret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) vret(i-1,j-1) = vret(i-1,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) uret(i-1,j-1) = uret(i-1,j-1) + & beta_lower(i,j) * dxdyh(i,j) * 1./24 * (u(i-1,j-1) + & @@ -4209,13 +4209,13 @@ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper uy = (u(i,j)-u(i,j-1))/dyh(i,j) vy = (v(i,j)-v(i,j-1))/dyh(i,j) - if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node uret(i,j-1) = uret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) vret(i,j-1) = vret(i,j-1) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (0./dxh(i,j)) + (4*vy+2*ux) * (-1./dyh(i,j))) uret(i,j-1) = uret(i,j-1) + & beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & @@ -4226,13 +4226,13 @@ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper u(i-1,j) + u(i,j-1)) endif - if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node uret(i-1,j) = uret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) vret(i-1,j) = vret(i-1,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (-1./dxh(i,j)) + (4*vy+2*ux) * (0./dyh(i,j))) uret(i,j-1) = uret(i,j-1) + & beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & @@ -4243,13 +4243,13 @@ subroutine CG_action_triangular (uret, vret, u, v, umask, vmask, hmask, nu_upper u(i-1,j) + u(i,j-1)) endif - if (umask(i,j) .eq. 1) then ! this (top right) is a degree of freedom node + if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node uret(i,j) = uret(i,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) vret(i,j) = vret(i,j) + & - .5 * dxdyh(i,j) * nu_upper (i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) + .5 * dxdyh(i,j) * nu_upper(i,j) * ((uy+vx) * (1./dxh(i,j)) + (4*vy+2*ux) * (1./dyh(i,j))) uret(i,j) = uret(i,j) + & beta_upper(i,j) * dxdyh(i,j) * 1./24 * (u(i,j) + & @@ -4270,12 +4270,12 @@ end subroutine CG_action_triangular subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmask, H_node, & nu, float_cond, D, beta, dxdyh, is, ie, js, je, dens_ratio) -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (inout) :: uret, vret -real, dimension (:,:,:,:), pointer :: Phi -real, dimension (:,:,:,:,:,:),pointer :: Phisub -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: u, v -real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: umask, vmask, H_node -real, dimension (:,:), intent (in) :: hmask, nu, float_cond, D, beta, dxdyh +real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (inout) :: uret, vret +real, dimension(:,:,:,:), pointer :: Phi +real, dimension(:,:,:,:,:,:),pointer :: Phisub +real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: u, v +real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: umask, vmask, H_node +real, dimension(:,:), intent (in) :: hmask, nu, float_cond, D, beta, dxdyh real, intent(in) :: dens_ratio integer, intent(in) :: is, ie, js, je @@ -4289,15 +4289,15 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas ! the linear action of the matrix on (u,v) with triangular finite elements ! Phi has the form -! Phi (i,j,k,q) - applies to cell i,j +! Phi(i,j,k,q) - applies to cell i,j ! 3 - 4 ! | | ! 1 - 2 -! Phi (i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q -! Phi (i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q -! Phi_k is equal to 1 at vertex k, and 0 at vertex l .ne. k, and bilinear +! Phi(i,j,2*k-1,q) gives d(Phi_k)/dx at quadrature point q +! Phi(i,j,2*k,q) gives d(Phi_k)/dy at quadrature point q +! Phi_k is equal to 1 at vertex k, and 0 at vertex l /= k, and bilinear real :: ux, vx, uy, vy, uq, vq, area, basel integer :: iq, jq, iphi, jphi, i, j, ilq, jlq @@ -4307,7 +4307,7 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) do j=js,je - do i=is,ie ; if (hmask(i,j) .eq. 1) then + do i=is,ie ; if (hmask(i,j) == 1) then ! dxh = G%dxh(i,j) ! dyh = G%dyh(i,j) ! @@ -4329,13 +4329,13 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas do iq=1,2 ; do jq=1,2 - if (iq .eq. 2) then + if (iq == 2) then ilq = 2 else ilq = 1 endif - if (jq .eq. 2) then + if (jq == 2) then jlq = 2 else jlq = 1 @@ -4372,68 +4372,68 @@ subroutine CG_action_bilinear (uret, vret, u, v, Phi, Phisub, umask, vmask, hmas v(i,j) * Phi(i,j,8,2*(jq-1)+iq) do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then + if (umask(i-2+iphi,j-2+jphi) == 1) then - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + & - .25 * area * nu (i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((4*ux+2*vy) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then + if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + & - .25 * area * nu (i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & + .25 * area * nu(i,j) * ((uy+vx) * Phi(i,j,2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(i,j,2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) endif - if (iq .eq. iphi) then + if (iq == iphi) then ilq = 2 else ilq = 1 endif - if (jq .eq. jphi) then + if (jq == jphi) then jlq = 2 else jlq = 1 endif - if (float_cond(i,j) .eq. 0) then + if (float_cond(i,j) == 0) then - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then + if (umask(i-2+iphi,j-2+jphi) == 1) then - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + & + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + & .25 * beta(i,j) * area * uq * xquad(ilq) * xquad(jlq) endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then + if (vmask(i-2+iphi,j-2+jphi) == 1) then - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + & + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + & .25 * beta(i,j) * area * vq * xquad(ilq) * xquad(jlq) endif endif Ucontr(iphi,jphi) = Ucontr(iphi,jphi) + .25 * area * uq * xquad(ilq) * xquad(jlq) * beta(i,j) -! if((i.eq.27) .and. (j.eq.8) .and. (iphi.eq.1) .and. (jphi.eq.1)) & +! if ((i == 27) .and. (j == 8) .and. (iphi == 1) .and. (jphi == 1)) & ! print *, "grid", uq, .25 * area * uq * xquad(ilq) * xquad(jlq) !endif enddo ; enddo enddo ; enddo - if (float_cond(i,j) .eq. 1) then + if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = D(i,j) Ucell(:,:) = u(i-1:i,j-1:j) ; Vcell(:,:) = v(i-1:i,j-1:j) ; Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_action_subgrid_basal_bilinear & (Phisub, Hcell, Ucell, Vcell, area, basel, dens_ratio, Usubcontr, Vsubcontr, i, j) do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - uret (i-2+iphi,j-2+jphi) = uret (i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) + if (umask(i-2+iphi,j-2+jphi) == 1) then + uret(i-2+iphi,j-2+jphi) = uret(i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - vret (i-2+iphi,j-2+jphi) = vret (i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) - !if ( (iphi.eq.1) .and. (jphi.eq.1)) 8 + if (vmask(i-2+iphi,j-2+jphi) == 1) then + vret(i-2+iphi,j-2+jphi) = vret(i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) + !if ( (iphi == 1) .and. (jphi == 1)) 8 ! print *, i,j, Usubcontr (iphi,jphi) * beta(i,j), " ", Ucontr(iphi,jphi) endif enddo ; enddo @@ -4483,7 +4483,7 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - if (dens_ratio * hloc - D .gt. 0) then + if (dens_ratio * hloc - D > 0) then !if (.true.) then uq = 0 ; vq = 0 do k=1,2 @@ -4497,7 +4497,7 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * uq Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * vq - ! if ((i_m .eq. 27) .and. (j_m .eq. 8) .and. (m.eq.1) .and. (n.eq.1)) & + ! if ((i_m == 27) .and. (j_m == 8) .and. (m == 1) .and. (n == 1)) & print *, "in subgrid", uq, Phisub(i,j,m,n,qx,qy) endif @@ -4511,14 +4511,14 @@ subroutine CG_action_subgrid_basal_bilinear (Phisub, H, U, V, DXDYH, D, dens_rat end subroutine CG_action_subgrid_basal_bilinear -subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) +subroutine matrix_diagonal_triangle(CS, u_diagonal, v_diagonal) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension (:,:), intent(inout) :: u_diagonal, v_diagonal + real, dimension(:,:), intent(inout) :: u_diagonal, v_diagonal ! returns the diagonal entries of the matrix for a Jacobi preconditioning - real, pointer, dimension (:,:) :: umask, vmask, & + real, pointer, dimension(:,:) :: umask, vmask, & nu_lower, nu_upper, beta_lower, beta_upper, hmask type(ocean_grid_type), pointer :: G integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec @@ -4540,130 +4540,130 @@ subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then + do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then dxh = G%dxT(i,j) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node ux = 1./dxh ; uy = 0./dyh vx = 0. ; vy = 0. - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) + u_diagonal(i,j-1) = u_diagonal(i,j-1) + & + .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & + u_diagonal(i,j-1) = u_diagonal(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 ux = 0. ; uy = 0. vx = 1./dxh ; vy = 0./dyh - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) + v_diagonal(i,j-1) = v_diagonal(i,j-1) + & + .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & + v_diagonal(i,j-1) = v_diagonal(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 ux = 0./dxh ; uy = -1./dyh vx = 0. ; vy = 0. - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) + u_diagonal(i,j-1) = u_diagonal(i,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & + u_diagonal(i,j-1) = u_diagonal(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 vx = 0./dxh ; vy = -1./dyh ux = 0. ; uy = 0. - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) + v_diagonal(i,j-1) = v_diagonal(i,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & + v_diagonal(i,j-1) = v_diagonal(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 endif - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node ux = 0./dxh ; uy = 1./dyh vx = 0. ; vy = 0. - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) + u_diagonal(i-1,j) = u_diagonal(i-1,j) + & + .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & + u_diagonal(i,j-1) = u_diagonal(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 ux = 0. ; uy = 0. vx = 0./dxh ; vy = 1./dyh - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) + v_diagonal(i-1,j) = v_diagonal(i-1,j) + & + .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & + v_diagonal(i,j-1) = v_diagonal(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 ux = -1./dxh ; uy = 0./dyh vx = 0. ; vy = 0. - u_diagonal (i-1,j) = u_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) + u_diagonal(i-1,j) = u_diagonal(i-1,j) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - u_diagonal (i,j-1) = u_diagonal (i,j-1) + & + u_diagonal(i,j-1) = u_diagonal(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 vx = -1./dxh ; vy = 0./dyh ux = 0. ; uy = 0. - v_diagonal (i-1,j) = v_diagonal (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) + v_diagonal(i-1,j) = v_diagonal(i-1,j) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - v_diagonal (i,j-1) = v_diagonal (i,j-1) + & + v_diagonal(i,j-1) = v_diagonal(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 endif - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node + if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node ux = -1./dxh ; uy = -1./dyh vx = 0. ; vy = 0. - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) + u_diagonal(i-1,j-1) = u_diagonal(i-1,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - u_diagonal (i-1,j-1) = u_diagonal (i-1,j-1) + & + u_diagonal(i-1,j-1) = u_diagonal(i-1,j-1) + & beta_lower(i,j) * dxdyh * 1./24 vx = -1./dxh ; vy = -1./dyh ux = 0. ; uy = 0. - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) + v_diagonal(i-1,j-1) = v_diagonal(i-1,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - v_diagonal (i-1,j-1) = v_diagonal (i-1,j-1) + & + v_diagonal(i-1,j-1) = v_diagonal(i-1,j-1) + & beta_lower(i,j) * dxdyh * 1./24 endif - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node + if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node ux = 1./ dxh ; uy = 1./dyh vx = 0. ; vy = 0. - u_diagonal (i,j) = u_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) + u_diagonal(i,j) = u_diagonal(i,j) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - u_diagonal (i,j) = u_diagonal (i,j) + & + u_diagonal(i,j) = u_diagonal(i,j) + & beta_upper(i,j) * dxdyh * 1./24 vx = 1./ dxh ; vy = 1./dyh ux = 0. ; uy = 0. - v_diagonal (i,j) = v_diagonal (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) + v_diagonal(i,j) = v_diagonal(i,j) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - v_diagonal (i,j) = v_diagonal (i,j) + & + v_diagonal(i,j) = v_diagonal(i,j) + & beta_upper(i,j) * dxdyh * 1./24 endif @@ -4674,16 +4674,16 @@ end subroutine matrix_diagonal_triangle subroutine matrix_diagonal_bilinear(CS, float_cond, H_node, dens_ratio, Phisub, u_diagonal, v_diagonal) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: H_node + real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(in) :: H_node real :: dens_ratio - real, dimension (:,:), intent(in) :: float_cond - real, dimension (:,:,:,:,:,:),pointer :: Phisub - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_diagonal, v_diagonal + real, dimension(:,:), intent(in) :: float_cond + real, dimension(:,:,:,:,:,:),pointer :: Phisub + real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_diagonal, v_diagonal ! returns the diagonal entries of the matrix for a Jacobi preconditioning - real, dimension (:,:), pointer :: umask, vmask, hmask, & + real, dimension(:,:), pointer :: umask, vmask, hmask, & nu, beta type(ocean_grid_type), pointer :: G integer :: isym, i, j, is, js, cnt, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq @@ -4718,18 +4718,18 @@ subroutine matrix_diagonal_bilinear(CS, float_cond, H_node, dens_ratio, Phisub, ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) .eq. 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then dxh = G%dxT(i,j) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - X(1:2) = G%geoLonBu (i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu (i-1:i,j) *1000 - Y(1:2) = G%geoLatBu (i-1:i,j-1) *1000 - Y(3:4) = G%geoLatBu (i-1:i,j)*1000 + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j) *1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1) *1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 - call bilinear_shape_functions (X, Y, Phi, area) + call bilinear_shape_functions(X, Y, Phi, area) ! X and Y must be passed in the form ! 3 - 4 @@ -4742,68 +4742,68 @@ subroutine matrix_diagonal_bilinear(CS, float_cond, H_node, dens_ratio, Phisub, do iphi=1,2 ; do jphi=1,2 - if (iq .eq. iphi) then + if (iq == iphi) then ilq = 2 else ilq = 1 endif - if (jq .eq. jphi) then + if (jq == jphi) then jlq = 2 else jlq = 1 endif - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then + if (umask(i-2+iphi,j-2+jphi) == 1) then ux = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) uy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) vx = 0. vy = 0. - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vy) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) uq = xquad(ilq) * xquad(jlq) - if (float_cond(i,j) .eq. 0) then - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + & + if (float_cond(i,j) == 0) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + & .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) endif endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then + if (vmask(i-2+iphi,j-2+jphi) == 1) then vx = Phi (2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) vy = Phi (2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) ux = 0. uy = 0. - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) vq = xquad(ilq) * xquad(jlq) - if (float_cond(i,j) .eq. 0) then - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + & + if (float_cond(i,j) == 0) then + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + & .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) endif endif enddo ; enddo enddo ; enddo - if (float_cond(i,j) .eq. 1) then + if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal_bilinear & (Phisub, Hcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi=1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - u_diagonal (i-2+iphi,j-2+jphi) = u_diagonal (i-2+iphi,j-2+jphi) + Usubcontr (iphi,jphi) * beta(i,j) - v_diagonal (i-2+iphi,j-2+jphi) = v_diagonal (i-2+iphi,j-2+jphi) + Vsubcontr (iphi,jphi) * beta(i,j) + if (umask(i-2+iphi,j-2+jphi) == 1) then + u_diagonal(i-2+iphi,j-2+jphi) = u_diagonal(i-2+iphi,j-2+jphi) + Usubcontr(iphi,jphi) * beta(i,j) + v_diagonal(i-2+iphi,j-2+jphi) = v_diagonal(i-2+iphi,j-2+jphi) + Vsubcontr(iphi,jphi) * beta(i,j) endif enddo ; enddo endif @@ -4835,7 +4835,7 @@ subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, hloc = Phisub(i,j,1,1,qx,qy)*H(1,1)+Phisub(i,j,1,2,qx,qy)*H(1,2)+& Phisub(i,j,2,1,qx,qy)*H(2,1)+Phisub(i,j,2,2,qx,qy)*H(2,2) - if (dens_ratio * hloc - D .gt. 0) then + if (dens_ratio * hloc - D > 0) then Ucontr (m,n) = Ucontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 Vcontr (m,n) = Vcontr (m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 endif @@ -4851,16 +4851,16 @@ subroutine CG_diagonal_subgrid_basal_bilinear (Phisub, H, DXDYH, D, dens_ratio, end subroutine CG_diagonal_subgrid_basal_bilinear -subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundary_contr) +subroutine apply_boundary_values_triangle(CS, time, u_boundary_contr, v_boundary_contr) type(time_type), intent(in) :: Time type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension (:,:), intent(inout) :: u_boundary_contr, v_boundary_contr + real, dimension(:,:), intent(inout) :: u_boundary_contr, v_boundary_contr ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function - real, pointer, dimension (:,:) :: u_boundary_values, & + real, pointer, dimension(:,:) :: u_boundary_values, & v_boundary_values, & umask, vmask, hmask, & nu_lower, nu_upper, beta_lower, beta_upper @@ -4888,9 +4888,9 @@ subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundar domain_width = CS%len_lat - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then + do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then - if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then + if ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then dxh = G%dxT(i,j) dyh = G%dyT(i,j) @@ -4901,60 +4901,60 @@ subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundar uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) + u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & + .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) + v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & + .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (0./dyh)) - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & + u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & + v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) endif - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) + u_boundary_contr(i-1,j) = u_boundary_contr(i-1,j) + & + .5 * dxdyh * nu_lower(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) - v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_lower (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) + v_boundary_contr(i-1,j) = v_boundary_contr(i-1,j) + & + .5 * dxdyh * nu_lower(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (1./dyh)) - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & + u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & + v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) endif - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node + if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node - u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) + u_boundary_contr(i-1,j-1) = u_boundary_contr(i-1,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) - v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) + v_boundary_contr(i-1,j-1) = v_boundary_contr(i-1,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (-1./dyh)) - u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & + u_boundary_contr(i-1,j-1) = u_boundary_contr(i-1,j-1) + & beta_lower(i,j) * dxdyh * 1./24 * (u_boundary_values(i-1,j-1) + & u_boundary_values(i-1,j) + u_boundary_values(i,j-1)) - v_boundary_contr (i-1,j-1) = v_boundary_contr (i-1,j-1) + & + v_boundary_contr(i-1,j-1) = v_boundary_contr(i-1,j-1) + & beta_lower(i,j) * dxdyh * 1./24 * (v_boundary_values(i-1,j-1) + & v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) endif endif - if ((umask(i,j) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then + if ((umask(i,j) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then dxh = G%dxT(i,j) dyh = G%dyT(i,j) @@ -4965,58 +4965,58 @@ subroutine apply_boundary_values_triangle (CS, time, u_boundary_contr, v_boundar uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) + u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) + v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (0./dxh) + (4*vy+2*ux) * (-1./dyh)) - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & + u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & u_boundary_values(i-1,j) + & u_boundary_values(i,j-1)) - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & + v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & u_boundary_values(i-1,j) + & u_boundary_values(i,j-1)) endif - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node - u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) + u_boundary_contr(i-1,j) = u_boundary_contr(i-1,j) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) - v_boundary_contr (i-1,j) = v_boundary_contr (i-1,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) + v_boundary_contr(i-1,j) = v_boundary_contr(i-1,j) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (-1./dxh) + (4*vy+2*ux) * (0./dyh)) - u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & + u_boundary_contr(i,j-1) = u_boundary_contr(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & u_boundary_values(i-1,j) + & u_boundary_values(i,j-1)) - v_boundary_contr (i,j-1) = v_boundary_contr (i,j-1) + & + v_boundary_contr(i,j-1) = v_boundary_contr(i,j-1) + & beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & u_boundary_values(i-1,j) + & u_boundary_values(i,j-1)) endif - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node + if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node - u_boundary_contr (i,j) = u_boundary_contr (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) + u_boundary_contr(i,j) = u_boundary_contr(i,j) + & + .5 * dxdyh * nu_upper(i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) - v_boundary_contr (i,j) = v_boundary_contr (i,j) + & - .5 * dxdyh * nu_upper (i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) + v_boundary_contr(i,j) = v_boundary_contr(i,j) + & + .5 * dxdyh * nu_upper(i,j) * ((uy+vx) * (1./dxh) + (4*vy+2*ux) * (1./dyh)) - u_boundary_contr (i,j) = u_boundary_contr (i,j) + & + u_boundary_contr(i,j) = u_boundary_contr(i,j) + & beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & u_boundary_values(i-1,j) + & u_boundary_values(i,j-1)) - v_boundary_contr (i,j) = v_boundary_contr (i,j) + & + v_boundary_contr(i,j) = v_boundary_contr(i,j) + & beta_upper(i,j) * dxdyh * 1./24 * (u_boundary_values(i,j) + & u_boundary_values(i-1,j) + & u_boundary_values(i,j-1)) @@ -5032,17 +5032,17 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, u_boundary_contr, v_boundary_contr) type(time_type), intent(in) :: Time - real, dimension (:,:,:,:,:,:),pointer:: Phisub + real, dimension(:,:,:,:,:,:),pointer:: Phisub type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: H_node - real, dimension (:,:), intent (in) :: float_cond + real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent (in) :: H_node + real, dimension(:,:), intent (in) :: float_cond real :: dens_ratio - real, dimension (NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_boundary_contr, v_boundary_contr + real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u_boundary_contr, v_boundary_contr ! this will be a per-setup function. the boundary values of thickness and velocity ! (and possibly other variables) will be updated in this function - real, pointer, dimension (:,:) :: u_boundary_values, & + real, pointer, dimension(:,:) :: u_boundary_values, & v_boundary_values, & umask, vmask, & nu, beta, hmask @@ -5081,25 +5081,25 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) .eq. 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then ! process this cell if any corners have umask set to non-dirichlet bdry. ! NOTE: vmask not considered, probably should be - if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. & - (umask(i-1,j) .eq. 3) .OR. (umask(i,j) .eq. 3)) then + if ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. & + (umask(i-1,j) == 3) .OR. (umask(i,j) == 3)) then dxh = G%dxT(i,j) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - X(1:2) = G%geoLonBu (i-1:i,j-1)*1000 - X(3:4) = G%geoLonBu (i-1:i,j)*1000 - Y(1:2) = G%geoLatBu (i-1:i,j-1)*1000 - Y(3:4) = G%geoLatBu (i-1:i,j)*1000 + X(1:2) = G%geoLonBu(i-1:i,j-1)*1000 + X(3:4) = G%geoLonBu(i-1:i,j)*1000 + Y(1:2) = G%geoLatBu(i-1:i,j-1)*1000 + Y(3:4) = G%geoLatBu(i-1:i,j)*1000 - call bilinear_shape_functions (X, Y, Phi, area) + call bilinear_shape_functions(X, Y, Phi, area) ! X and Y must be passed in the form ! 3 - 4 @@ -5144,41 +5144,41 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, do iphi=1,2 ; do jphi=1,2 - if (iq .eq. iphi) then + if (iq == iphi) then ilq = 2 else ilq = 1 endif - if (jq .eq. jphi) then + if (jq == jphi) then jlq = 2 else jlq = 1 endif - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then + if (umask(i-2+iphi,j-2+jphi) == 1) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + u_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - if (float_cond(i,j) .eq. 0) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & + if (float_cond(i,j) == 0) then + u_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & .25 * beta(i,j) * dxdyh * uq * xquad(ilq) * xquad(jlq) endif endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then + if (vmask(i-2+iphi,j-2+jphi) == 1) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - .25 * dxdyh * nu (i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + v_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & + .25 * dxdyh * nu(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - if (float_cond(i,j) .eq. 0) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & + if (float_cond(i,j) == 0) then + v_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & .25 * beta(i,j) * dxdyh * vq * xquad(ilq) * xquad(jlq) endif @@ -5186,20 +5186,20 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, enddo ; enddo enddo ; enddo - if (float_cond(i,j) .eq. 1) then + if (float_cond(i,j) == 1) then Usubcontr = 0.0 ; Vsubcontr = 0.0 ; basel = G%bathyT(i,j) Ucell(:,:) = u_boundary_values(i-1:i,j-1:j) ; Vcell(:,:) = v_boundary_values(i-1:i,j-1:j) Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_action_subgrid_basal_bilinear & (Phisub, Hcell, Ucell, Vcell, dxdyh, basel, dens_ratio, Usubcontr, Vsubcontr) do iphi=1,2 ; do jphi = 1,2 - if (umask (i-2+iphi,j-2+jphi) .eq. 1) then - u_boundary_contr (i-2+iphi,j-2+jphi) = u_boundary_contr (i-2+iphi,j-2+jphi) + & - Usubcontr(iphi,jphi) * beta (i,j) + if (umask(i-2+iphi,j-2+jphi) == 1) then + u_boundary_contr(i-2+iphi,j-2+jphi) = u_boundary_contr(i-2+iphi,j-2+jphi) + & + Usubcontr(iphi,jphi) * beta(i,j) endif - if (vmask (i-2+iphi,j-2+jphi) .eq. 1) then - v_boundary_contr (i-2+iphi,j-2+jphi) = v_boundary_contr (i-2+iphi,j-2+jphi) + & - Vsubcontr(iphi,jphi) * beta (i,j) + if (vmask(i-2+iphi,j-2+jphi) == 1) then + v_boundary_contr(i-2+iphi,j-2+jphi) = v_boundary_contr(i-2+iphi,j-2+jphi) + & + Vsubcontr(iphi,jphi) * beta(i,j) endif enddo ; enddo endif @@ -5208,7 +5208,7 @@ subroutine apply_boundary_values_bilinear(CS, time, Phisub, H_node, float_cond, end subroutine apply_boundary_values_bilinear -subroutine calc_shelf_visc_triangular (CS,u,v) +subroutine calc_shelf_visc_triangular(CS,u,v) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(:,:), intent(inout) :: u, v @@ -5219,11 +5219,11 @@ subroutine calc_shelf_visc_triangular (CS,u,v) ! this may be subject to change later... to make it "hybrid" - real, pointer, dimension (:,:) :: nu_lower , & + real, pointer, dimension(:,:) :: nu_lower , & nu_upper, & beta_eff_lower, & beta_eff_upper - real, pointer, dimension (:,:) :: H, &! thickness + real, pointer, dimension(:,:) :: H, &! thickness hmask type(ocean_grid_type), pointer :: G @@ -5265,7 +5265,7 @@ subroutine calc_shelf_visc_triangular (CS,u,v) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - if (hmask (i,j) .eq. 1) then + if (hmask(i,j) == 1) then ux = (u(i,j-1)-u(i-1,j-1)) / dxh vx = (v(i,j-1)-v(i-1,j-1)) / dxh uy = (u(i-1,j)-u(i-1,j-1)) / dyh @@ -5275,7 +5275,7 @@ subroutine calc_shelf_visc_triangular (CS,u,v) umid = 1./3 * (u(i-1,j-1)+u(i-1,j)+u(i,j-1)) vmid = 1./3 * (v(i-1,j-1)+v(i-1,j)+v(i,j-1)) unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - beta_eff_lower (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + beta_eff_lower(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) ux = (u(i,j)-u(i-1,j)) / dxh vx = (v(i,j)-v(i-1,j)) / dxh @@ -5286,7 +5286,7 @@ subroutine calc_shelf_visc_triangular (CS,u,v) umid = 1./3 * (u(i,j)+u(i-1,j)+u(i,j-1)) vmid = 1./3 * (v(i,j)+v(i-1,j)+v(i,j-1)) unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) - beta_eff_upper (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + beta_eff_upper(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) endif enddo @@ -5294,7 +5294,7 @@ subroutine calc_shelf_visc_triangular (CS,u,v) end subroutine calc_shelf_visc_triangular -subroutine calc_shelf_visc_bilinear (CS, u, v) +subroutine calc_shelf_visc_bilinear(CS, u, v) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(NILIMB_SYM_,NJLIMB_SYM_), intent(inout) :: u, v @@ -5305,9 +5305,9 @@ subroutine calc_shelf_visc_bilinear (CS, u, v) ! this may be subject to change later... to make it "hybrid" - real, pointer, dimension (:,:) :: nu, & + real, pointer, dimension(:,:) :: nu, & beta - real, pointer, dimension (:,:) :: H, &! thickness + real, pointer, dimension(:,:) :: H, &! thickness hmask type(ocean_grid_type), pointer :: G @@ -5341,7 +5341,7 @@ subroutine calc_shelf_visc_bilinear (CS, u, v) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - if (hmask (i,j) .eq. 1) then + if (hmask(i,j) == 1) then ux = (u(i,j) + u(i,j-1) - u(i-1,j) - u(i-1,j-1)) / (2*dxh) vx = (v(i,j) + v(i,j-1) - v(i-1,j) - v(i-1,j-1)) / (2*dxh) uy = (u(i,j) - u(i,j-1) + u(i-1,j) - u(i-1,j-1)) / (2*dyh) @@ -5351,14 +5351,14 @@ subroutine calc_shelf_visc_bilinear (CS, u, v) umid = (u(i,j) + u(i,j-1) + u(i-1,j) + u(i-1,j-1))/4 vmid = (v(i,j) + v(i,j-1) + v(i-1,j) + v(i-1,j-1))/4 - unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta (i,j) = C_basal_friction * unorm ** (n_basal_friction-1) + unorm = sqrt (umid**2+vmid**2+(eps_min*dxh)**2) ; beta(i,j) = C_basal_friction * unorm ** (n_basal_friction-1) endif enddo enddo end subroutine calc_shelf_visc_bilinear -subroutine update_OD_ffrac (CS, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) +subroutine update_OD_ffrac(CS, ocean_mass, counter, nstep_velocity, time_step, velocity_update_time_step) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(CS%grid%isd:,CS%grid%jsd:) :: ocean_mass integer,intent(in) :: counter @@ -5388,12 +5388,12 @@ subroutine update_OD_ffrac (CS, ocean_mass, counter, nstep_velocity, time_step, enddo enddo - if (counter .eq. nstep_velocity) then + if (counter == nstep_velocity) then do j=jsc,jec do i=isc,iec CS%float_frac(i,j) = 1.0 - (CS%float_frac_rt(i,j) / real(nstep_velocity)) -! if ((CS%float_frac(i,j) .gt. 0) .and. (CS%float_frac(i,j) .lt. 1)) then +! if ((CS%float_frac(i,j) > 0) .and. (CS%float_frac(i,j) < 1)) then ! print *,"PARTLY GROUNDED", CS%float_frac(i,j),i,j,mpp_pe() ! endif CS%OD_av(i,j) = CS%OD_rt(i,j) / real(nstep_velocity) @@ -5409,7 +5409,7 @@ subroutine update_OD_ffrac (CS, ocean_mass, counter, nstep_velocity, time_step, end subroutine update_OD_ffrac -subroutine update_OD_ffrac_uncoupled (CS) +subroutine update_OD_ffrac_uncoupled(CS) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), pointer :: G @@ -5432,13 +5432,13 @@ subroutine update_OD_ffrac_uncoupled (CS) do j=jsd,jed do i=isd,ied - OD = G%bathyT(i,j) - rhoi/rhow * h_shelf (i,j) - if (OD.ge.0) then + OD = G%bathyT(i,j) - rhoi/rhow * h_shelf(i,j) + if (OD >= 0) then ! ice thickness does not take up whole ocean column -> floating - OD_av (i,j) = OD + OD_av(i,j) = OD float_frac(i,j) = 0. else - OD_av (i,j) = 0. + OD_av(i,j) = 0. float_frac(i,j) = 1. endif enddo @@ -5464,12 +5464,12 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) ! ! Phi (2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi (2*i,j) gives d(Phi_i)/dy at quadrature point j -! Phi_i is equal to 1 at vertex i, and 0 at vertex k .ne. i, and bilinear +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear ! ! This should be a one-off; once per nonlinear solve? once per lifetime? ! ... will all cells have the same shape and dimension? - real, dimension (4) :: xquad, yquad + real, dimension(4) :: xquad, yquad integer :: node, qpoint, xnode, xq, ynode, yq real :: a,b,c,d,e,f,xexp,yexp @@ -5487,13 +5487,13 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) - if (ynode .eq. 1) then + if (ynode == 1) then yexp = 1-yquad(qpoint) else yexp = yquad(qpoint) endif - if (1 .eq. xnode) then + if (1 == xnode) then xexp = 1-xquad(qpoint) else xexp = xquad(qpoint) @@ -5522,7 +5522,7 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) ! i think this general approach may not work for nonrectangular elements... ! - ! Phisub (i,j,k,l,q1,q2) + ! Phisub(i,j,k,l,q1,q2) ! i: subgrid index in x-direction ! j: subgrid index in y-direction ! k: basis function x-index @@ -5556,17 +5556,17 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) do k=1,2 do l=1,2 val = 1.0 - if (k .eq. 1) then + if (k == 1) then val = val * (1.0-x) else val = val * x endif - if (l .eq. 1) then + if (l == 1) then val = val * (1.0-y) else val = val * y endif - Phisub (i,j,k,l,qx,qy) = val + Phisub(i,j,k,l,qx,qy) = val enddo enddo enddo @@ -5580,7 +5580,7 @@ subroutine bilinear_shape_functions_subgrid (Phisub, nsub) end subroutine bilinear_shape_functions_subgrid -subroutine update_velocity_masks (CS) +subroutine update_velocity_masks(CS) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure ! sets masks for velocity solve @@ -5621,8 +5621,8 @@ subroutine update_velocity_masks (CS) isym = 0 - umask (:,:) = 0 ; vmask (:,:) = 0 - u_face_mask (:,:) = 0 ; v_face_mask (:,:) = 0 + umask(:,:) = 0 ; vmask(:,:) = 0 + u_face_mask(:,:) = 0 ; v_face_mask(:,:) = 0 if (G%symmetric) then is = isd ; js = jsd @@ -5633,7 +5633,7 @@ subroutine update_velocity_masks (CS) do j=js,G%jed do i=is,G%ied - if (hmask(i,j) .eq. 1) then + if (hmask(i,j) == 1) then umask(i-1:i,j-1:j) = 1. vmask(i-1:i,j-1:j) = 1. @@ -5685,47 +5685,47 @@ subroutine update_velocity_masks (CS) enddo !if (u_face_mask_boundary(i-1,j).geq.0) then !left boundary - ! u_face_mask (i-1,j) = u_face_mask_boundary(i-1,j) - ! umask (i-1,j-1:j) = 3. - ! vmask (i-1,j-1:j) = 0. + ! u_face_mask(i-1,j) = u_face_mask_boundary(i-1,j) + ! umask(i-1,j-1:j) = 3. + ! vmask(i-1,j-1:j) = 0. !endif - !if (j_off+j .eq. gjsc+1) then !bot boundary - ! v_face_mask (i,j-1) = 0. + !if (j_off+j == gjsc+1) then !bot boundary + ! v_face_mask(i,j-1) = 0. ! umask (i-1:i,j-1) = 0. ! vmask (i-1:i,j-1) = 0. - !elseif (j_off+j .eq. gjec) then !top boundary - ! v_face_mask (i,j) = 0. + !elseif (j_off+j == gjec) then !top boundary + ! v_face_mask(i,j) = 0. ! umask (i-1:i,j) = 0. ! vmask (i-1:i,j) = 0. !endif - if (i .lt. G%ied) then - if ((hmask(i+1,j) .eq. 0) & - .OR. (hmask(i+1,j) .eq. 2)) then + if (i < G%ied) then + if ((hmask(i+1,j) == 0) & + .OR. (hmask(i+1,j) == 2)) then !right boundary or adjacent to unfilled cell - u_face_mask (i,j) = 2. + u_face_mask(i,j) = 2. endif endif - if (i .gt. G%isd) then - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then + if (i > G%isd) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then !adjacent to unfilled cell - u_face_mask (i-1,j) = 2. + u_face_mask(i-1,j) = 2. endif endif - if (j .gt. G%jsd) then - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then + if (j > G%jsd) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then !adjacent to unfilled cell - v_face_mask (i,j-1) = 2. + v_face_mask(i,j-1) = 2. endif endif - if (j .lt. G%jed) then - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then + if (j < G%jed) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then !adjacent to unfilled cell - v_face_mask (i,j) = 2. + v_face_mask(i,j) = 2. endif endif @@ -5739,12 +5739,12 @@ subroutine update_velocity_masks (CS) ! so this subroutine must update its own symmetric part of the halo call pass_vector(u_face_mask, v_face_mask, G%domain, TO_ALL, CGRID_NE) - call pass_vector (umask,vmask,G%domain,TO_ALL,BGRID_NE) + call pass_vector(umask,vmask,G%domain,TO_ALL,BGRID_NE) end subroutine update_velocity_masks -subroutine interpolate_H_to_B (CS, h_shelf, hmask, H_node) +subroutine interpolate_H_to_B(CS, h_shelf, hmask, H_node) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, dimension(:,:), intent(in) :: h_shelf, hmask real, dimension(NILIMB_SYM_,NJLIMB_SYM_), & @@ -5768,13 +5768,13 @@ subroutine interpolate_H_to_B (CS, h_shelf, hmask, H_node) num_h = 0 do k=0,1 do l=0,1 - if (hmask (i+k,j+l) .eq. 1.0) then - summ = summ + h_shelf (i+k,j+l) + if (hmask(i+k,j+l) == 1.0) then + summ = summ + h_shelf(i+k,j+l) num_h = num_h + 1 endif enddo enddo - if (num_h .gt. 0) then + if (num_h > 0) then H_node(i,j) = summ / num_h endif enddo @@ -5794,7 +5794,7 @@ subroutine ice_shelf_end(CS) deallocate(CS%t_flux) ; deallocate(CS%lprec) deallocate(CS%salt_flux) - deallocate(CS%tflux_shelf) ; deallocate(CS%tfreeze); + deallocate(CS%tflux_shelf) ; deallocate(CS%tfreeze) deallocate(CS%exch_vel_t) ; deallocate(CS%exch_vel_s) deallocate(CS%h_shelf) ; deallocate(CS%hmask) @@ -5802,7 +5802,7 @@ subroutine ice_shelf_end(CS) if (CS%shelf_mass_is_dynamic .and. .not.CS%override_shelf_movement) then deallocate(CS%u_shelf) ; deallocate(CS%v_shelf) !!! OVS !!! - deallocate(CS%t_shelf); deallocate(CS%tmask); + deallocate(CS%t_shelf); deallocate(CS%tmask) deallocate(CS%t_boundary_values) deallocate(CS%u_boundary_values) ; deallocate(CS%v_boundary_values) deallocate(CS%ice_visc_bilinear) @@ -5852,7 +5852,7 @@ subroutine savearray2(fname,A,flag) OPEN(unit=fin,FILE=fname,STATUS='REPLACE',ACCESS='SEQUENTIAL',& ACTION='WRITE',IOSTAT=iock) -IF(M .gt. 1300) THEN +if (M > 1300) THEN WRITE(fin) 'SECOND DIMENSION TOO LARGE' CLOSE(fin) RETURN @@ -5866,7 +5866,7 @@ subroutine savearray2(fname,A,flag) END DO - IF(i.eq.1) THEN + if (i == 1) THEN lh = LEN(TRIM(ln)) @@ -5893,7 +5893,7 @@ subroutine savearray2(fname,A,flag) WRITE(UNIT=fin,IOSTAT=iock,FMT=TRIM(FMT1)) TRIM(ln) - IF(iock .ne. 0) THEN + if (iock /= 0) THEN PRINT*,iock END IF END DO @@ -5903,7 +5903,7 @@ subroutine savearray2(fname,A,flag) end subroutine savearray2 -subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) +subroutine solo_time_step(CS, time_step, n, Time, min_time_step_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real,intent(in) :: time_step integer, intent(inout) :: n @@ -5940,7 +5940,7 @@ subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) ! dumtimeprint=time_type_to_real(Time)/spy if (is_root_pe()) print *, "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/spy - do while (time_step_remain .gt. 0.0) + do while (time_step_remain > 0.0) min_ratio = 1.0e16 n=n+1 @@ -5949,18 +5949,18 @@ subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) local_u_max = 0 ; local_v_max = 0 - if (hmask (i,j) .eq. 1.0) then + if (hmask(i,j) == 1.0) then ! all 4 corners of the cell should have valid velocity values; otherwise something is wrong ! this is done by checking that umask and vmask are nonzero at all 4 corners do ki=1,2 ; do kj = 1,2 - local_u_max = max (local_u_max, abs(u_shelf(i-1+ki,j-1+kj))) - local_v_max = max (local_v_max, abs(v_shelf(i-1+ki,j-1+kj))) + local_u_max = max(local_u_max, abs(u_shelf(i-1+ki,j-1+kj))) + local_v_max = max(local_v_max, abs(v_shelf(i-1+ki,j-1+kj))) enddo ; enddo - ratio = min (G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) - min_ratio = min (min_ratio, ratio) + ratio = min(G%areaT(i,j) / (local_u_max+1.0e-12), G%areaT(i,j) / (local_v_max+1.0e-12)) + min_ratio = min(min_ratio, ratio) endif enddo ! j loop @@ -5968,19 +5968,19 @@ subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) ! solved velocities are in m/yr; we want m/s - call mpp_min (min_ratio) + call mpp_min(min_ratio) time_step_int = min(CS%CFL_factor * min_ratio * (365*86400), time_step) - if (time_step_int .lt. min_time_step) then - call MOM_error (FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep") + if (time_step_int < min_time_step) then + call MOM_error(FATAL, "MOM_ice_shelf:solo_time_step: abnormally small timestep") else if (is_root_pe()) then write(*,*) "Ice model timestep: ", time_step_int, " seconds" endif endif - if (time_step_int .ge. time_step_remain) then + if (time_step_int >= time_step_remain) then time_step_int = time_step_remain time_step_remain = 0.0 else @@ -5989,9 +5989,9 @@ subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) write (stepnum,'(I4)') CS%velocity_update_sub_counter - call ice_shelf_advect (CS, time_step_int, CS%lprec, Time) + call ice_shelf_advect(CS, time_step_int, CS%lprec, Time) - if (mpp_pe() .eq. 7) then + if (mpp_pe() == 7) then call savearray2 ("hmask",CS%hmask,CS%write_output_to_file) !!! OVS!!! ! call savearray2 ("tshelf",CS%t_shelf,CS%write_output_to_file) @@ -5999,18 +5999,18 @@ subroutine solo_time_step (CS, time_step, n, Time, min_time_step_in) ! if the last mini-timestep is a day or less, we cannot expect velocities to change by much. ! do not update them - if (time_step_int .gt. 1000) then - call update_velocity_masks (CS) + if (time_step_int > 1000) then + call update_velocity_masks(CS) ! call savearray2 ("Umask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%umask,CS%write_output_to_file) ! call savearray2 ("Vmask"//"p"//trim(procnum)//"_"//trim(stepnum),CS%vmask,CS%write_output_to_file) - call update_OD_ffrac_uncoupled (CS) - call ice_shelf_solve_outer (CS, CS%u_shelf, CS%v_shelf, 1, iters, dummy) + call update_OD_ffrac_uncoupled(CS) + call ice_shelf_solve_outer(CS, CS%u_shelf, CS%v_shelf, 1, iters, dummy) endif !!! OVS!!! - call ice_shelf_temp (CS, time_step_int, CS%lprec, Time) + call ice_shelf_temp(CS, time_step_int, CS%lprec, Time) call enable_averaging(time_step,Time,CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, CS%area_shelf_h, CS%diag) @@ -6065,10 +6065,10 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) ! ###Perhaps flux_enter should be changed into u-face and v-face ! ###fluxes, which can then be used in halo updates, etc. ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! THESE ARE NOT CONSISTENT ==> FIND OUT WHAT YOU IMPLEMENTED @@ -6100,16 +6100,16 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec - flux_enter (:,:,:) = 0.0 + flux_enter(:,:,:) = 0.0 - th_after_uflux (:,:) = 0.0 - th_after_vflux (:,:) = 0.0 + th_after_uflux(:,:) = 0.0 + th_after_vflux(:,:) = 0.0 do j=jsd,jed do i=isd,ied t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) .gt. 1) then - if ((CS%hmask(i,j) .eq. 3) .or. (CS%hmask(i,j) .eq. -2)) then +! if (CS%hmask(i,j) > 1) then + if ((CS%hmask(i,j) == 3) .or. (CS%hmask(i,j) == -2)) then CS%t_shelf(i,j) = CS%t_boundary_values(i,j) endif enddo @@ -6117,32 +6117,32 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) do j=jsd,jed do i=isd,ied - TH (i,j) = CS%t_shelf(i,j)*CS%h_shelf (i,j) + TH(i,j) = CS%t_shelf(i,j)*CS%h_shelf(i,j) enddo enddo ! call enable_averaging(time_step,Time,CS%diag) - ! call pass_var (h_after_uflux, G%domain) + ! call pass_var(h_after_uflux, G%domain) ! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) ! call disable_averaging(CS%diag) ! call enable_averaging(time_step,Time,CS%diag) -! call pass_var (h_after_vflux, G%domain) +! call pass_var(h_after_vflux, G%domain) ! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) ! call disable_averaging(CS%diag) - call ice_shelf_advect_temp_x (CS, time_step/spy, TH, th_after_uflux, flux_enter) - call ice_shelf_advect_temp_y (CS, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) + call ice_shelf_advect_temp_x(CS, time_step/spy, TH, th_after_uflux, flux_enter) + call ice_shelf_advect_temp_y(CS, time_step/spy, th_after_uflux, th_after_vflux, flux_enter) do j=jsd,jed do i=isd,ied -! if (CS%hmask(i,j) .eq. 1) then - if (CS%h_shelf(i,j) .gt. 0.0) then - CS%t_shelf (i,j) = th_after_vflux(i,j)/CS%h_shelf (i,j) +! if (CS%hmask(i,j) == 1) then + if (CS%h_shelf(i,j) > 0.0) then + CS%t_shelf(i,j) = th_after_vflux(i,j)/CS%h_shelf(i,j) else CS%t_shelf(i,j) = -10.0 endif @@ -6152,8 +6152,8 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) do j=jsd,jed do i=isd,ied t_bd = CS%t_boundary_values(i,j) -! if (CS%hmask(i,j) .gt. 1) then - if ((CS%hmask(i,j) .eq. 3) .or. (CS%hmask(i,j) .eq. -2)) then +! if (CS%hmask(i,j) > 1) then + if ((CS%hmask(i,j) == 3) .or. (CS%hmask(i,j) == -2)) then CS%t_shelf(i,j) = t_bd ! CS%t_shelf(i,j) = -15.0 endif @@ -6162,10 +6162,10 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) do j=jsc,jec do i=isc,iec - if ((CS%hmask(i,j) .eq. 1) .or. (CS%hmask(i,j) .eq. 2)) then - if (CS%h_shelf(i,j) .gt. 0.0) then -! CS%t_shelf (i,j) = CS%t_shelf (i,j) + time_step*(adot*Tsurf -melt_rate (i,j)*Tbot(i,j))/CS%h_shelf (i,j) - CS%t_shelf (i,j) = CS%t_shelf (i,j) + time_step*(adot*Tsurf -3/spy*Tbot(i,j))/CS%h_shelf (i,j) + if ((CS%hmask(i,j) == 1) .or. (CS%hmask(i,j) == 2)) then + if (CS%h_shelf(i,j) > 0.0) then +! CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -melt_rate(i,j)*Tbot(i,j))/CS%h_shelf(i,j) + CS%t_shelf(i,j) = CS%t_shelf(i,j) + time_step*(adot*Tsurf -3/spy*Tbot(i,j))/CS%h_shelf(i,j) else ! the ice is about to melt away ! in this case set thickness, area, and mask to zero @@ -6183,13 +6183,13 @@ subroutine ice_shelf_temp(CS, time_step, melt_rate, Time) call pass_var(CS%tmask, G%domain) if (CS%DEBUG) then - call hchksum (CS%t_shelf, "temp after front", G%HI, haloshift=3) + call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3) endif end subroutine ice_shelf_temp -subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter) +subroutine ice_shelf_advect_temp_x(CS, time_step, h0, h_after_uflux, flux_enter) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, intent(in) :: time_step real, dimension(:,:), intent(in) :: h0 @@ -6202,10 +6202,10 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -6244,29 +6244,29 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter i_off = G%idg_offset ; j_off = G%jdg_offset do j=jsd+1,jed-1 - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then ! based on mehmet's code - only if btw north & south boundaries stencil(:) = -1 -! if (i+i_off .eq. G%domain%nihalo+G%domain%nihalo) +! if (i+i_off == G%domain%nihalo+G%domain%nihalo) do i=is,ie - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then - if (i+i_off .eq. G%domain%nihalo+1) then + if (i+i_off == G%domain%nihalo+1) then at_west_bdry=.true. else at_west_bdry=.false. endif - if (i+i_off .eq. G%domain%niglobal+G%domain%nihalo) then + if (i+i_off == G%domain%niglobal+G%domain%nihalo) then at_east_bdry=.true. else at_east_bdry=.false. endif - if (hmask(i,j) .eq. 1) then + if (hmask(i,j) == 1) then dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) @@ -6278,9 +6278,9 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter ! 1ST DO LEFT FACE - if (u_face_mask (i-1,j) .eq. 4.) then + if (u_face_mask(i-1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i-1,j) * & + flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i-1,j) * & t_boundary(i-1,j) / dxdyh ! assume no flux bc for temp ! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary(i-1,j) / dxdyh @@ -6290,20 +6290,20 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter ! get u-velocity at center of left face u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - ! if (at_west_bdry .and. (i .eq. G%isc)) then + ! if (at_west_bdry .and.(i == G%isc)) then ! print *, j, u_face, stencil(-1) ! endif - if (u_face .gt. 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available + if (u_face > 0) then !flux is into cell - we need info from h(i-2), h(i-1) if available ! i may not cover all the cases.. but i cover the realistic ones - if (at_west_bdry .AND. (hmask(i-1,j).eq.3)) then ! at western bdry but there is a + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it stencil (-1) = CS%t_boundary_values(i-1,j)*CS%h_shelf(i-1,j) flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(-1) / dxdyh - elseif (hmask(i-1,j) * hmask(i-2,j) .eq. 1) then ! h(i-2) and h(i-1) are valid + elseif (hmask(i-1,j) * hmask(i-2,j) == 1) then ! h(i-2) and h(i-1) are valid phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh* time_step / dxdyh * & (stencil(-1) - phi * (stencil(-1)-stencil(0))/2) @@ -6316,8 +6316,8 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter endif - elseif (u_face .lt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid + elseif (u_face < 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) @@ -6325,7 +6325,7 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter else flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - if ((hmask(i-1,j) .eq. 0) .OR. (hmask(i-1,j) .eq. 2)) then + if ((hmask(i-1,j) == 0) .OR. (hmask(i-1,j) == 2)) then flux_enter(i-1,j,2) = ABS(u_face) * dyh * time_step * stencil(0) endif endif @@ -6336,25 +6336,25 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter ! get u-velocity at center of right face - if (u_face_mask (i+1,j) .eq. 4.) then + if (u_face_mask(i+1,j) == 4.) then - flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values (i+1,j) *& + flux_diff_cell = flux_diff_cell + dyh * time_step * u_flux_boundary_values(i+1,j) *& t_boundary(i+1,j)/ dxdyh ! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary (i+1,j)/ dxdyh +! flux_diff_cell = flux_diff_cell + dyh * time_step * CS%u_shelf(i,j)*t_boundary(i+1,j)/ dxdyh else u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) - if (u_face .lt. 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available + if (u_face < 0) then !flux is into cell - we need info from h(i+2), h(i+1) if available - if (at_east_bdry .AND. (hmask(i+1,j).eq.3)) then ! at eastern bdry but there is a + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step * stencil(1) / dxdyh - elseif (hmask(i+1,j) * hmask(i+2,j) .eq. 1) then ! h(i+2) and h(i+1) are valid + elseif (hmask(i+1,j) * hmask(i+2,j) == 1) then ! h(i+2) and h(i+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) flux_diff_cell = flux_diff_cell + ABS(u_face) * dyh * time_step / dxdyh * & @@ -6368,9 +6368,9 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter endif - elseif (u_face .gt. 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available + elseif (u_face > 0) then !flux is out of cell - we need info from h(i-1), h(i+1) if available - if (hmask(i-1,j) * hmask(i+1,j) .eq. 1) then ! h(i-1) and h(i+1) are both valid + if (hmask(i-1,j) * hmask(i+1,j) == 1) then ! h(i-1) and h(i+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * & @@ -6382,7 +6382,7 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter flux_diff_cell = flux_diff_cell - ABS(u_face) * dyh * time_step / dxdyh * stencil(0) - if ((hmask(i+1,j) .eq. 0) .OR. (hmask(i+1,j) .eq. 2)) then + if ((hmask(i+1,j) == 0) .OR. (hmask(i+1,j) == 2)) then flux_enter(i+1,j,1) = ABS(u_face) * dyh * time_step * stencil(0) endif @@ -6395,34 +6395,34 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter endif - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - if (at_west_bdry .AND. (hmask(i-1,j) .EQ. 3)) then + if (at_west_bdry .AND. (hmask(i-1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i-1,j-1) + CS%u_shelf(i-1,j)) - flux_enter (i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i-1,j)* & + flux_enter(i,j,1) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i-1,j)* & CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i-1,j) .eq. 4.) then - flux_enter (i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values (i-1,j)*t_boundary(i-1,j) -! flux_enter (i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary (i-1,j) + elseif (u_face_mask(i-1,j) == 4.) then + flux_enter(i,j,1) = G%dyT(i,j) * time_step * u_flux_boundary_values(i-1,j)*t_boundary(i-1,j) +! flux_enter(i,j,1) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary(i-1,j) ! assume no flux bc for temp endif - if (at_east_bdry .AND. (hmask(i+1,j) .EQ. 3)) then + if (at_east_bdry .AND. (hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(i,j-1) + CS%u_shelf(i,j)) flux_enter(i,j,2) = ABS(u_face) * G%dyT(i,j) * time_step * t_boundary(i+1,j)* & CS%thickness_boundary_values(i+1,j) - elseif (u_face_mask (i+1,j) .eq. 4.) then - flux_enter (i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values (i+1,j) * t_boundary(i+1,j) + elseif (u_face_mask(i+1,j) == 4.) then + flux_enter(i,j,2) = G%dyT(i,j) * time_step * u_flux_boundary_values(i+1,j) * t_boundary(i+1,j) ! assume no flux bc for temp -! flux_enter (i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary (i+1,j) +! flux_enter(i,j,2) = G%dyh(i,j) * time_step * CS%u_shelf(i,j)*t_boundary(i+1,j) endif -! if ((i .eq. is) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i-1,j) .eq. 1)) then +! if ((i == is) .AND. (hmask(i,j) == 0) .AND. (hmask(i-1,j) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered ! hmask(i,j) = 2 -! elseif ((i .eq. ie) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i+1,j) .eq. 1)) then +! elseif ((i == ie) .AND. (hmask(i,j) == 0) .AND. (hmask(i+1,j) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered @@ -6444,7 +6444,7 @@ subroutine ice_shelf_advect_temp_x (CS, time_step, h0, h_after_uflux, flux_enter end subroutine ice_shelf_advect_temp_x -subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, flux_enter) +subroutine ice_shelf_advect_temp_y(CS, time_step, h_after_uflux, h_after_vflux, flux_enter) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure real, intent(in) :: time_step real, dimension(:,:), intent(in) :: h_after_uflux @@ -6457,10 +6457,10 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, ! flux_enter(isd:ied,jsd:jed,1:4): if cell is not ice-covered, gives flux of ice into cell from kth boundary ! - ! from left neighbor: flux_enter (:,:,1) - ! from right neighbor: flux_enter (:,:,2) - ! from bottom neighbor: flux_enter (:,:,3) - ! from top neighbor: flux_enter (:,:,4) + ! from left neighbor: flux_enter(:,:,1) + ! from right neighbor: flux_enter(:,:,2) + ! from bottom neighbor: flux_enter(:,:,3) + ! from top neighbor: flux_enter(:,:,4) ! ! o--- (4) ---o ! | | @@ -6497,57 +6497,57 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, i_off = G%idg_offset ; j_off = G%jdg_offset do i=isd+2,ied-2 - if (((i+i_off) .le. G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) .ge. G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries + if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & + ((i+i_off) >= G%domain%nihalo+1)) then ! based on mehmet's code - only if btw east & west boundaries stencil(:) = -1 do j=js,je - if (((j+j_off) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) .ge. G%domain%njhalo+1)) then + if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+j_off) >= G%domain%njhalo+1)) then - if (j+j_off .eq. G%domain%njhalo+1) then + if (j+j_off == G%domain%njhalo+1) then at_south_bdry=.true. else at_south_bdry=.false. endif - if (j+j_off .eq. G%domain%njglobal+G%domain%njhalo) then + if (j+j_off == G%domain%njglobal+G%domain%njhalo) then at_north_bdry=.true. else at_north_bdry=.false. endif - if (hmask(i,j) .eq. 1) then + if (hmask(i,j) == 1) then dxh = G%dxT(i,j) ; dyh = G%dyT(i,j) ; dxdyh = G%areaT(i,j) - h_after_vflux (i,j) = h_after_uflux (i,j) + h_after_vflux(i,j) = h_after_uflux(i,j) - stencil (:) = h_after_uflux (i,j-2:j+2) ! fine as long has ny_halo >= 2 + stencil(:) = h_after_uflux(i,j-2:j+2) ! fine as long has ny_halo >= 2 flux_diff_cell = 0 ! 1ST DO south FACE - if (v_face_mask (i,j-1) .eq. 4.) then + if (v_face_mask(i,j-1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j-1) * & + flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j-1) * & t_boundary(i,j-1)/ dxdyh ! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary (i,j-1) / dxdyh +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary(i,j-1) / dxdyh else ! get u-velocity at center of left face v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - if (v_face .gt. 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available + if (v_face > 0) then !flux is into cell - we need info from h(j-2), h(j-1) if available ! i may not cover all the cases.. but i cover the realistic ones - if (at_south_bdry .AND. (hmask(i,j-1).eq.3)) then ! at western bdry but there is a + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then ! at western bdry but there is a ! thickness bdry condition, and the stencil contains it flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(-1) / dxdyh - elseif (hmask(i,j-1) * hmask(i,j-2) .eq. 1) then ! h(j-2) and h(j-1) are valid + elseif (hmask(i,j-1) * hmask(i,j-2) == 1) then ! h(j-2) and h(j-1) are valid phi = slope_limiter (stencil(-1)-stencil(-2), stencil(0)-stencil(-1)) flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & @@ -6559,16 +6559,16 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(-1) endif - elseif (v_face .lt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + elseif (v_face < 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(1), stencil(-1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & (stencil(0) - phi * (stencil(0)-stencil(-1))/2) else flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j-1) .eq. 0) .OR. (hmask(i,j-1) .eq. 2)) then + if ((hmask(i,j-1) == 0) .OR. (hmask(i,j-1) == 2)) then flux_enter(i,j-1,4) = ABS(v_face) * dyh * time_step * stencil(0) endif @@ -6580,24 +6580,24 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, ! NEXT DO north FACE - if (v_face_mask(i,j+1) .eq. 4.) then + if (v_face_mask(i,j+1) == 4.) then - flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values (i,j+1) *& + flux_diff_cell = flux_diff_cell + dxh * time_step * v_flux_boundary_values(i,j+1) *& t_boundary(i,j+1)/ dxdyh ! assume no flux bc for temp -! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary (i,j+1) / dxdyh +! flux_diff_cell = flux_diff_cell + dxh * time_step * CS%v_shelf(i,j)*t_boundary(i,j+1) / dxdyh else ! get u-velocity at center of right face v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - if (v_face .lt. 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available + if (v_face < 0) then !flux is into cell - we need info from h(j+2), h(j+1) if available - if (at_north_bdry .AND. (hmask(i,j+1).eq.3)) then ! at eastern bdry but there is a + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then ! at eastern bdry but there is a ! thickness bdry condition, and the stencil contains it flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step * stencil(1) / dxdyh - elseif (hmask(i,j+1) * hmask(i,j+2) .eq. 1) then ! h(j+2) and h(j+1) are valid + elseif (hmask(i,j+1) * hmask(i,j+2) == 1) then ! h(j+2) and h(j+1) are valid phi = slope_limiter (stencil(1)-stencil(2), stencil(0)-stencil(1)) flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * & (stencil(1) - phi * (stencil(1)-stencil(0))/2) @@ -6607,9 +6607,9 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, flux_diff_cell = flux_diff_cell + ABS(v_face) * dxh * time_step / dxdyh * stencil(1) endif - elseif (v_face .gt. 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available + elseif (v_face > 0) then !flux is out of cell - we need info from h(j-1), h(j+1) if available - if (hmask(i,j-1) * hmask(i,j+1) .eq. 1) then ! h(j-1) and h(j+1) are both valid + if (hmask(i,j-1) * hmask(i,j+1) == 1) then ! h(j-1) and h(j+1) are both valid phi = slope_limiter (stencil(0)-stencil(-1), stencil(1)-stencil(0)) flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * & (stencil(0) - phi * (stencil(0)-stencil(1))/2) @@ -6617,7 +6617,7 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, ! (o.w. flux would most likely be out of cell) ! but h(j+2) is not flux_diff_cell = flux_diff_cell - ABS(v_face) * dxh * time_step / dxdyh * stencil(0) - if ((hmask(i,j+1) .eq. 0) .OR. (hmask(i,j+1) .eq. 2)) then + if ((hmask(i,j+1) == 0) .OR. (hmask(i,j+1) == 2)) then flux_enter(i,j+1,3) = ABS(v_face) * dxh * time_step * stencil(0) endif endif @@ -6626,41 +6626,41 @@ subroutine ice_shelf_advect_temp_y (CS, time_step, h_after_uflux, h_after_vflux, endif - h_after_vflux (i,j) = h_after_vflux (i,j) + flux_diff_cell + h_after_vflux(i,j) = h_after_vflux(i,j) + flux_diff_cell - elseif ((hmask(i,j) .eq. 0) .OR. (hmask(i,j) .eq. 2)) then + elseif ((hmask(i,j) == 0) .OR. (hmask(i,j) == 2)) then - if (at_south_bdry .AND. (hmask(i,j-1) .EQ. 3)) then + if (at_south_bdry .AND. (hmask(i,j-1) == 3)) then v_face = 0.5 * (CS%v_shelf(i-1,j-1) + CS%v_shelf(i,j-1)) - flux_enter (i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j-1)* & + flux_enter(i,j,3) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j-1)* & CS%thickness_boundary_values(i,j-1) - elseif (v_face_mask(i,j-1) .eq. 4.) then - flux_enter (i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j-1)*t_boundary(i,j-1) + elseif (v_face_mask(i,j-1) == 4.) then + flux_enter(i,j,3) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j-1)*t_boundary(i,j-1) ! assume no flux bc for temp -! flux_enter (i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary (i,j-1) +! flux_enter(i,j,3) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary(i,j-1) endif - if (at_north_bdry .AND. (hmask(i,j+1) .EQ. 3)) then + if (at_north_bdry .AND. (hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(i-1,j) + CS%v_shelf(i,j)) - flux_enter (i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j+1)* & + flux_enter(i,j,4) = ABS(v_face) * G%dxT(i,j) * time_step * t_boundary(i,j+1)* & CS%thickness_boundary_values(i,j+1) - elseif (v_face_mask(i,j+1) .eq. 4.) then - flux_enter (i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values (i,j+1)*t_boundary(i,j+1) + elseif (v_face_mask(i,j+1) == 4.) then + flux_enter(i,j,4) = G%dxT(i,j) * time_step * v_flux_boundary_values(i,j+1)*t_boundary(i,j+1) ! assume no flux bc for temp -! flux_enter (i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary (i,j+1) +! flux_enter(i,j,4) = G%dxh(i,j) * time_step * CS%v_shelf(i,j)*t_boundary(i,j+1) endif -! if ((j .eq. js) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j-1) .eq. 1)) then +! if ((j == js) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j-1) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing ! the front without having to call pass_var - if cell is empty and cell to left ! is ice-covered then this cell will become partly covered - ! hmask (i,j) = 2 - ! elseif ((j .eq. je) .AND. (hmask(i,j) .eq. 0) .AND. (hmask(i,j+1) .eq. 1)) then + ! hmask(i,j) = 2 + ! elseif ((j == je) .AND. (hmask(i,j) == 0) .AND. (hmask(i,j+1) == 1)) then ! this is solely for the purposes of keeping the mask consistent while advancing the ! front without having to call pass_var - if cell is empty and cell to left is ! ice-covered then this cell will become partly covered -! hmask (i,j) = 2 +! hmask(i,j) = 2 ! endif endif diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index bc12e77679..38d56e7481 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -108,10 +108,10 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, ! taper ice shelf in area where there is no sidestress - ! but do not interfere with hmask - if ((G%geoLonCv(i,j) .gt. len_sidestress).and. & - (len_sidestress .gt. 0.)) then + if ((G%geoLonCv(i,j) > len_sidestress).and. & + (len_sidestress > 0.)) then udh = exp (-(G%geoLonCv(i,j)-len_sidestress)/5.0) * h_shelf(i,j) - if (udh .le. 25.0) then + if (udh <= 25.0) then h_shelf(i,j) = 0.0 area_shelf_h (i,j) = 0.0 else @@ -121,11 +121,11 @@ subroutine initialize_ice_thickness_from_file (h_shelf, area_shelf_h, hmask, G, ! update thickness mask - if (area_shelf_h (i,j) .ge. G%areaT(i,j)) then + if (area_shelf_h (i,j) >= G%areaT(i,j)) then hmask(i,j) = 1. - elseif (area_shelf_h (i,j) .eq. 0.0) then + elseif (area_shelf_h (i,j) == 0.0) then hmask(i,j) = 0. - elseif ((area_shelf_h(i,j) .gt. 0) .and. (area_shelf_h(i,j) .le. G%areaT(i,j))) then + elseif ((area_shelf_h(i,j) > 0) .and. (area_shelf_h(i,j) <= G%areaT(i,j))) then hmask(i,j) = 2. else call MOM_error(FATAL,mdl// " AREA IN CELL OUT OF RANGE") @@ -176,7 +176,7 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF do i=G%isc,G%iec - if ((j.ge.jsc) .and. (j.le.jec)) then + if ((j >= jsc) .and. (j <= jec)) then if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. @@ -209,7 +209,7 @@ subroutine initialize_ice_thickness_channel (h_shelf, area_shelf_h, hmask, G, PF endif endif - if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then + if ((i+G%idg_offset) == G%domain%nihalo+1) then hmask(i-1,j) = 3.0 endif @@ -248,7 +248,7 @@ end subroutine initialize_ice_thickness_channel ! "flux condition", default=.true.) ! select case ( trim(config) ) -! case ("CHANNEL"); +! case ("CHANNEL") ! call initialize_ice_shelf_boundary_channel(u_face_mask_boundary, & ! v_face_mask_boundary, u_flux_boundary_values, v_flux_boundary_values, & ! u_boundary_values, v_boundary_values, h_boundary_values, hmask, G, & @@ -311,7 +311,7 @@ end subroutine initialize_ice_thickness_channel ! ! upstream boundary - set either dirichlet or flux condition -! if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then +! if ((i+G%idg_offset) == G%domain%nihalo+1) then ! if (flux_bdry) then ! u_face_mask_boundary (i-1,j) = 4.0 ! u_flux_boundary_values (i-1,j) = input_flux @@ -328,14 +328,14 @@ end subroutine initialize_ice_thickness_channel ! ! side boundaries: no flow -! if (G%jdg_offset+j .eq. gjsc+1) then !bot boundary -! if (len_stress .eq. 0. .OR. G%geoLonCv(i,j-1) .le. len_stress) then +! if (G%jdg_offset+j == gjsc+1) then !bot boundary +! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then ! v_face_mask_boundary (i,j-1) = 0. ! else ! v_face_mask_boundary (i,j-1) = 1. ! endif -! elseif (G%jdg_offset+j .eq. gjec) then !top boundary -! if (len_stress .eq. 0. .OR. G%geoLonCv(i,j-1) .le. len_stress) then +! elseif (G%jdg_offset+j == gjec) then !top boundary +! if (len_stress == 0. .OR. G%geoLonCv(i,j-1) <= len_stress) then ! v_face_mask_boundary (i,j) = 0. ! else ! v_face_mask_boundary (i,j) = 1. @@ -344,7 +344,7 @@ end subroutine initialize_ice_thickness_channel ! ! downstream boundary - CFBC -! if (i+G%idg_offset .eq. giec) then +! if (i+G%idg_offset == giec) then ! u_face_mask_boundary(i,j) = 2.0 ! endif diff --git a/src/ice_shelf/shelf_triangular_FEstuff.F90 b/src/ice_shelf/shelf_triangular_FEstuff.F90 index 6829774386..5c4fbaf213 100644 --- a/src/ice_shelf/shelf_triangular_FEstuff.F90 +++ b/src/ice_shelf/shelf_triangular_FEstuff.F90 @@ -124,7 +124,7 @@ module shelf_triangular_FEstuff ! ~ once a day (maybe longer) because it will depend on ocean values ! that are averaged over this time interval, and the solve will begin ! to lose meaning if it is done too frequently - integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve; + integer :: velocity_update_sub_counter ! there is no outer loop for the velocity solve ! the counter will have to be stored integer :: velocity_update_counter ! the "outer" timestep number integer :: nstep_velocity ! ~ (velocity_update_time_step / time_step) @@ -192,12 +192,12 @@ subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) nu_lower => CS%ice_visc_lower_tri ; nu_upper => CS%ice_visc_upper_tri beta_lower => CS%taub_beta_eff_lower_tri ; beta_upper => CS%taub_beta_eff_upper_tri - do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then + do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then dxh = G%dxT(i,j) dyh = G%dyT(i,j) dxdyh = G%areaT(i,j) - if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + if (umask (i,j-1) == 1) then ! this (bot right) is a degree of freedom node ux = 1./dxh ; uy = 0./dyh vx = 0. ; vy = 0. @@ -237,7 +237,7 @@ subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) endif - if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + if (umask (i-1,j) == 1) then ! this (top left) is a degree of freedom node ux = 0./dxh ; uy = 1./dyh vx = 0. ; vy = 0. @@ -277,7 +277,7 @@ subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) endif - if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node + if (umask (i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node ux = -1./dxh ; uy = -1./dyh vx = 0. ; vy = 0. @@ -298,7 +298,7 @@ subroutine matrix_diagonal_triangle (CS, u_diagonal, v_diagonal) beta_lower(i,j) * dxdyh * 1./24 endif - if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node + if (umask (i,j) == 1) then ! this (top right) is a degree of freedom node ux = 1./ dxh ; uy = 1./dyh vx = 0. ; vy = 0. @@ -360,9 +360,9 @@ end subroutine matrix_diagonal_triangle !~ domain_width = CS%len_lat - !~ do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) .eq. 1) then + !~ do i=isc-1,iec+1 ; do j=jsc-1,jec+1 ; if (hmask(i,j) == 1) then - !~ if ((umask(i-1,j-1) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then + !~ if ((umask(i-1,j-1) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then !~ dxh = G%dxh(i,j) !~ dyh = G%dyh(i,j) @@ -373,7 +373,7 @@ end subroutine matrix_diagonal_triangle !~ uy = (u_boundary_values(i-1,j)-u_boundary_values(i-1,j-1))/dyh !~ vy = (v_boundary_values(i-1,j)-v_boundary_values(i-1,j-1))/dyh - !~ if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + !~ if (umask (i,j-1) == 1) then ! this (bot right) is a degree of freedom node !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (0./dyh)) @@ -390,7 +390,7 @@ end subroutine matrix_diagonal_triangle !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) !~ endif - !~ if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + !~ if (umask (i-1,j) == 1) then ! this (top left) is a degree of freedom node !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & !~ .5 * dxdyh * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (1./dyh)) @@ -407,7 +407,7 @@ end subroutine matrix_diagonal_triangle !~ v_boundary_values(i-1,j) + v_boundary_values(i,j-1)) !~ endif - !~ if (umask (i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node + !~ if (umask (i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node !~ u_boundary_contr (i-1,j-1) = u_boundary_contr (i-1,j-1) + & !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (-1./dyh)) @@ -426,7 +426,7 @@ end subroutine matrix_diagonal_triangle !~ endif - !~ if ((umask(i,j) .eq. 3) .OR. (umask(i,j-1) .eq. 3) .OR. (umask(i-1,j) .eq. 3)) then + !~ if ((umask(i,j) == 3) .OR. (umask(i,j-1) == 3) .OR. (umask(i-1,j) == 3)) then !~ dxh = G%dxh(i,j) !~ dyh = G%dyh(i,j) @@ -437,7 +437,7 @@ end subroutine matrix_diagonal_triangle !~ uy = (u_boundary_values(i,j)-u_boundary_values(i,j-1))/dyh !~ vy = (v_boundary_values(i,j)-v_boundary_values(i,j-1))/dyh - !~ if (umask (i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + !~ if (umask (i,j-1) == 1) then ! this (bot right) is a degree of freedom node !~ u_boundary_contr (i,j-1) = u_boundary_contr (i,j-1) + & !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh) + (uy+vy) * (-1./dyh)) @@ -456,7 +456,7 @@ end subroutine matrix_diagonal_triangle !~ u_boundary_values(i,j-1)) !~ endif - !~ if (umask (i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + !~ if (umask (i-1,j) == 1) then ! this (top left) is a degree of freedom node !~ u_boundary_contr (i-1,j) = u_boundary_contr (i-1,j) + & !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh) + (uy+vy) * (0./dyh)) @@ -475,7 +475,7 @@ end subroutine matrix_diagonal_triangle !~ u_boundary_values(i,j-1)) !~ endif - !~ if (umask (i,j) .eq. 1) then ! this (top right) is a degree of freedom node + !~ if (umask (i,j) == 1) then ! this (top right) is a degree of freedom node !~ u_boundary_contr (i,j) = u_boundary_contr (i,j) + & !~ .5 * dxdyh * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh) + (uy+vy) * (1./dyh)) @@ -551,7 +551,7 @@ end subroutine matrix_diagonal_triangle !~ dyh = G%dyh(i,j) !~ dxdyh = G%dxdyh(i,j) - !~ if (hmask (i,j) .eq. 1) then + !~ if (hmask (i,j) == 1) then !~ ux = (u(i,j-1)-u(i-1,j-1)) / dxh !~ vx = (v(i,j-1)-v(i-1,j-1)) / dxh !~ uy = (u(i-1,j)-u(i-1,j-1)) / dyh @@ -605,14 +605,14 @@ end subroutine matrix_diagonal_triangle !~ do i=is,ie !~ do j=js,je - !~ if (hmask(i,j) .eq. 1) then ! this cell's vertices contain degrees of freedom + !~ if (hmask(i,j) == 1) then ! this cell's vertices contain degrees of freedom !~ ux = (u(i,j-1)-u(i-1,j-1))/dxh(i,j) !~ vx = (v(i,j-1)-v(i-1,j-1))/dxh(i,j) !~ uy = (u(i-1,j)-u(i-1,j-1))/dyh(i,j) !~ vy = (v(i-1,j)-v(i-1,j-1))/dyh(i,j) - !~ if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + !~ if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node !~ uret(i,j-1) = uret(i,j-1) + & !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) @@ -629,7 +629,7 @@ end subroutine matrix_diagonal_triangle !~ v(i-1,j) + v(i,j-1)) !~ endif - !~ if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + !~ if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node !~ uret(i-1,j) = uret(i-1,j) + & !~ .5 * dxdyh(i,j) * nu_lower (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) @@ -646,7 +646,7 @@ end subroutine matrix_diagonal_triangle !~ v(i-1,j) + v(i,j-1)) !~ endif - !~ if (umask(i-1,j-1) .eq. 1) then ! this (bot left) is a degree of freedom node + !~ if (umask(i-1,j-1) == 1) then ! this (bot left) is a degree of freedom node !~ uret(i-1,j-1) = uret(i-1,j-1) + & !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) @@ -669,7 +669,7 @@ end subroutine matrix_diagonal_triangle !~ uy = (u(i,j)-u(i,j-1))/dyh(i,j) !~ vy = (v(i,j)-v(i,j-1))/dyh(i,j) - !~ if (umask(i,j-1) .eq. 1) then ! this (bot right) is a degree of freedom node + !~ if (umask(i,j-1) == 1) then ! this (bot right) is a degree of freedom node !~ uret(i,j-1) = uret(i,j-1) + & !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (0./dxh(i,j)) + (uy+vy) * (-1./dyh(i,j))) @@ -686,7 +686,7 @@ end subroutine matrix_diagonal_triangle !~ u(i-1,j) + u(i,j-1)) !~ endif - !~ if (umask(i-1,j) .eq. 1) then ! this (top left) is a degree of freedom node + !~ if (umask(i-1,j) == 1) then ! this (top left) is a degree of freedom node !~ uret(i-1,j) = uret(i-1,j) + & !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (-1./dxh(i,j)) + (uy+vy) * (0./dyh(i,j))) @@ -703,7 +703,7 @@ end subroutine matrix_diagonal_triangle !~ u(i-1,j) + u(i,j-1)) !~ endif - !~ if (umask(i,j) .eq. 1) then ! this (top right) is a degree of freedom node + !~ if (umask(i,j) == 1) then ! this (top right) is a degree of freedom node !~ uret(i,j) = uret(i,j) + & !~ .5 * dxdyh(i,j) * nu_upper (i,j) * ((4*ux+2*vy) * (1./dxh(i,j)) + (uy+vy) * (1./dyh(i,j))) diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index 24afa9026b..7c523dea5f 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -31,7 +31,7 @@ module user_shelf_init !* subroutine. * !* * !* Forcing-related fields (taux, tauy, buoy, ustar, etc.) are set * -!* in MOM_surface_forcing.F90. * +!* in MOM_surface_forcing.F90. * !* * !* These variables are all set in the set of subroutines (in this * !* file) USER_initialize_bottom_depth, USER_initialize_thickness, * @@ -190,17 +190,17 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C c1 = 0.0 ; if (CS%shelf_slope_scale > 0.0) c1 = 1.0 / CS%shelf_slope_scale - do j=G%jsd,G%jed ; + do j=G%jsd,G%jed - if (((j+G%jdg_offset) .le. G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+G%jdg_offset) .ge. G%domain%njhalo+1)) then + if (((j+G%jdg_offset) <= G%domain%njglobal+G%domain%njhalo) .AND. & + ((j+G%jdg_offset) >= G%domain%njhalo+1)) then do i=G%isc,G%iec ! if (((i+G%idg_offset) <= G%domain%niglobal+G%domain%nihalo) .AND. & ! ((i+G%idg_offset) >= G%domain%nihalo+1)) then - if ((j.ge.G%jsc) .and. (j.le.G%jec)) then + if ((j >= G%jsc) .and. (j <= G%jec)) then if (new_sim) then ; if (G%geoLonCu(i-1,j) >= edge_pos) then ! Everything past the edge is open ocean. @@ -232,7 +232,7 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C endif ; endif ; endif - if ((i+G%idg_offset) .eq. G%domain%nihalo+1) then + if ((i+G%idg_offset) == G%domain%nihalo+1) then hmask(i-1,j) = 3.0 endif diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 7aff08540a..0275bfc205 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -241,7 +241,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF) call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, & "The (diagnosed) maximum depth of the ocean.", units="m") endif - if (trim(config) .ne. "DOME") then + if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth) endif diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 7709af5d0e..ba84d55763 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -278,7 +278,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file) global_indices(3) = 1+SGdom%njhalo global_indices(4) = SGdom%njglobal+SGdom%njhalo exni(:) = 2*exni(:) ; exnj(:) = 2*exnj(:) - if(associated(G%domain%maskmap)) then + if (associated(G%domain%maskmap)) then call MOM_define_domain(global_indices, SGdom%layout, SGdom%mpp_domain, & xflags=G%domain%X_FLAGS, yflags=G%domain%Y_FLAGS, & xhalo=SGdom%nihalo, yhalo=SGdom%njhalo, & @@ -477,7 +477,7 @@ subroutine set_grid_metrics_cartesian(G, param_file) call callTree_enter("set_grid_metrics_cartesian(), MOM_grid_initialize.F90") - PI = 4.0*atan(1.0) ; + PI = 4.0*atan(1.0) call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & "The units for the Cartesian axes. Valid entries are: \n"//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index b26e13b61e..49153586b7 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1678,7 +1678,7 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) ! reference surface layer salinity and temperature and a specified range. ! Note that the linear distribution is set up with respect to the layer ! number, not the physical position). - integer :: k; + integer :: k real :: delta_S, delta_T real :: S_top, T_top ! Reference salinity and temerature within surface layer real :: S_range, T_range ! Range of salinities and temperatures over the vertical @@ -1705,10 +1705,10 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) if (just_read) return ! All run-time parameters have been read, so return. ! ! Prescribe salinity -! delta_S = S_range / ( G%ke - 1.0 ); -! S(:,:,1) = S_top; +! delta_S = S_range / ( G%ke - 1.0 ) +! S(:,:,1) = S_top ! do k = 2,G%ke -! S(:,:,k) = S(:,:,k-1) + delta_S; +! S(:,:,k) = S(:,:,k-1) + delta_S ! end do do k = 1,G%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(G%ke)) @@ -1716,13 +1716,13 @@ subroutine initialize_temp_salt_linear(T, S, G, param_file, just_read_params) end do ! ! Prescribe temperature -! delta_T = T_range / ( G%ke - 1.0 ); -! T(:,:,1) = T_top; +! delta_T = T_range / ( G%ke - 1.0 ) +! T(:,:,1) = T_top ! do k = 2,G%ke -! T(:,:,k) = T(:,:,k-1) + delta_T; +! T(:,:,k) = T(:,:,k-1) + delta_T ! end do -! delta = 1; -! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0; +! delta = 1 +! T(:,:,G%ke/2 - (delta-1):G%ke/2 + delta) = 1.0 call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear diff --git a/src/initialization/midas_vertmap.F90 b/src/initialization/midas_vertmap.F90 index 7cdc440f62..373062ffc3 100644 --- a/src/initialization/midas_vertmap.F90 +++ b/src/initialization/midas_vertmap.F90 @@ -79,11 +79,11 @@ function wright_eos_2d(T,S,p) result(rho) real(kind=8) :: al0,lam,p0,I_denom integer :: i,k - a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; - b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; - b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; - c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; - c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; + a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 + b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 + b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 + c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 + c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -120,11 +120,11 @@ function alpha_wright_eos_2d(T,S,p) result(drho_dT) real(kind=8) :: al0,lam,p0,I_denom,I_denom2 integer :: i,k -a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; -b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; -b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; -c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; -c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; +a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 +b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 +b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 +c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 +c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -167,11 +167,11 @@ function beta_wright_eos_2d(T,S,p) result(drho_dS) real(kind=8) :: al0,lam,p0,I_denom,I_denom2 integer :: i,k -a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7; -b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4; -b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3; -c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422; -c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464; +a0 = 7.057924e-4; a1 = 3.480336e-7; a2 = -1.112733e-7 +b0 = 5.790749e8; b1 = 3.516535e6; b2 = -4.002714e4 +b3 = 2.084372e2; b4 = 5.944068e5; b5 = -9.643486e3 +c0 = 1.704853e5; c1 = 7.904722e2; c2 = -7.984422 +c3 = 5.140652e-2; c4 = -2.302158e2; c5 = -3.079464 do k=1,size(T,2) do i=1,size(T,1) @@ -262,7 +262,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, do j=1,ny i_loop: do i=1,nx - if (nlevs_data(i,j) .eq. 0 .or. wet(i,j) .eq. 0.) then + if (nlevs_data(i,j) == 0 .or. wet(i,j) == 0.) then tr(i,j,:) = land_fill cycle i_loop endif @@ -297,7 +297,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0001 k,k_top,k_bot,sum(wt),sum(z2-z1) = ',k,k_top,k_bot,sum(wt),sum(z2-z1) endif endif @@ -321,7 +321,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, ! endif if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0002 k,k_top,k_bot,k_bot_prev,sl_tr = ',k,k_top,k_bot,k_bot_prev,sl_tr endif endif @@ -333,7 +333,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0003 k,tr = ',k,tr(i,j,k) endif endif @@ -357,7 +357,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, if (debug_) then if (PRESENT(i_debug)) then - if (i.eq.i_debug.and.j.eq.j_debug) then + if (i == i_debug.and.j == j_debug) then print *,'0004 k,kz,nlevs,sl_tr,tr = ',k,kz,nlevs_data(i,j),sl_tr,tr(i,j,k) print *,'0005 k,kz,tr(kz),tr(kz-1),tr(kz+1) = ',k,kz,tr_1d(kz),tr_1d(kz-1),tr_1d(kz+1),z_edges(kz+2) endif @@ -371,7 +371,7 @@ function tracer_z_init(tr_in,z_edges,e,nkml,nkbl,land_fill,wet,nlay,nlevs,debug, enddo ! k-loop do k=2,nlay ! simply fill vanished layers with adjacent value - if (e_1d(k)-e_1d(k+1) .le. epsln) tr(i,j,k)=tr(i,j,k-1) + if (e_1d(k)-e_1d(k+1) <= epsln) tr(i,j,k)=tr(i,j,k-1) enddo enddo i_loop @@ -792,7 +792,7 @@ function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) if (dir == 1) then do k=2,nlevs_data(i,j)-1 if (rho_(i,k) - rho_(i,k-1) < 0.0 ) then - if (k.eq.2) then + if (k == 2) then rho_(i,k-1)=rho_(i,k)-epsln else drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) @@ -807,7 +807,7 @@ function find_interfaces(rho,zin,Rb,depth,nlevs,nkml,nkbl,hml,debug) result(zi) else do k=nlevs_data(i,j)-1,2,-1 if (rho_(i,k+1) - rho_(i,k) < 0.0) then - if (k .eq. nlevs_data(i,j)-1) then + if (k == nlevs_data(i,j)-1) then rho_(i,k+1)=rho_(i,k-1)+epsln else drhodz = (rho_(i,k+1)-rho_(i,k-1))/(zin(k+1)-zin(k-1)) @@ -922,7 +922,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then B(i,j,1)=1-nm(i+1,j);B(i,j,2)=1-nm(i-1,j) B(i,j,3)=1-nm(i,j+1);B(i,j,4)=1-nm(i,j-1) endif @@ -932,7 +932,7 @@ subroutine smooth_heights(zi,fill,bad,sor,niter,cyclic_x, tripolar_n) do n=1,niter do j=1,nj do i=1,ni - if (fill(i,j) .eq. 1) then + if (fill(i,j) == 1) then bsum = real(B(i,j,1)+B(i,j,2)+B(i,j,3)+B(i,j,4)) Isum = 1.0/bsum res(i,j)=Isum*(B(i,j,1)*mp(i+1,j)+B(i,j,2)*mp(i-1,j)+& diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index f60e4ce013..2672308fd7 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -208,7 +208,7 @@ subroutine init_oda(Time, G, GV, CS) allocate(CS%domains(CS%ensemble_size)) CS%domains(CS%ensemble_id)%mpp_domain => G%Domain%mpp_domain do n=1,CS%ensemble_size - if(.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) + if (.not. associated(CS%domains(n)%mpp_domain)) allocate(CS%domains(n)%mpp_domain) call set_root_pe(CS%ensemble_pelist(n,1)) call mpp_broadcast_domain(CS%domains(n)%mpp_domain) enddo @@ -248,7 +248,7 @@ subroutine init_oda(Time, G, GV, CS) call initialize_remapping(CS%remapCS,'PLM') call set_regrid_params(CS%regridCS, min_thickness=0.) call mpp_get_data_domain(G%Domain%mpp_domain,isd,ied,jsd,jed) - if(.not. associated(CS%h)) then + if (.not. associated(CS%h)) then allocate(CS%h(isd:ied,jsd:jed,CS%GV%ke)); CS%h(:,:,:)=0.0 ! assign thicknesses call ALE_initThicknessToCoord(CS%ALE_CS,G,CS%GV,CS%h) @@ -310,7 +310,7 @@ subroutine init_oda(Time, G, GV, CS) T_grid%mask(i,j,k) = 1.0 end if end do; end do - if (k .eq. 1) then + if (k == 1) then T_grid%z(:,:,k) = global2D/2 else T_grid%z(:,:,k) = T_grid%z(:,:,k-1) + (global2D + global2D_old)/2 @@ -350,7 +350,7 @@ subroutine set_prior_tracer(Time, G, GV, h, tv, CS) !! switch to global pelist call set_current_pelist(CS%filter_pelist) - if(is_root_pe()) print *, 'Setting prior' + if (is_root_pe()) print *, 'Setting prior' isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec call mpp_get_compute_domain(CS%domains(CS%ensemble_id)%mpp_domain,is,ie,js,je) @@ -410,12 +410,12 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) !! switch to global pelist call set_current_pelist(CS%filter_pelist) - if(is_root_pe()) print *, 'Getting posterior' + if (is_root_pe()) print *, 'Getting posterior' get_inc = .true. - if(present(increment)) get_inc = increment + if (present(increment)) get_inc = increment - if(get_inc) then + if (get_inc) then allocate(Ocean_increment) call init_ocean_ensemble(Ocean_increment,CS%Grid,CS%GV,CS%ensemble_size) Ocean_increment%T = CS%Ocean_posterior%T - CS%Ocean_prior%T @@ -423,7 +423,7 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) endif isc=CS%Grid%isc;iec=CS%Grid%iec;jsc=CS%Grid%jsc;jec=CS%Grid%jec do m=1,CS%ensemble_size - if(get_inc) then + if (get_inc) then call mpp_redistribute(CS%mpp_domain, Ocean_increment%T(:,:,:,m), & CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) call mpp_redistribute(CS%mpp_domain, Ocean_increment%S(:,:,:,m), & @@ -436,14 +436,14 @@ subroutine get_posterior_tracer(Time, CS, G, GV, h, tv, increment) endif if (CS%Ocean_posterior%id_t(m)>0) then - if(get_inc) then + if (get_inc) then used=send_data(CS%Ocean_posterior%id_t(m), Ocean_increment%T(isc:iec,jsc:jec,:,m), CS%Time) else used=send_data(CS%Ocean_posterior%id_t(m), CS%Ocean_posterior%T(isc:iec,jsc:jec,:,m), CS%Time) endif endif if (CS%Ocean_posterior%id_s(m)>0) then - if(get_inc) then + if (get_inc) then used=send_data(CS%Ocean_posterior%id_s(m), Ocean_increment%S(isc:iec,jsc:jec,:,m), CS%Time) else used=send_data(CS%Ocean_posterior%id_s(m), CS%Ocean_posterior%S(isc:iec,jsc:jec,:,m), CS%Time) @@ -525,9 +525,9 @@ subroutine set_analysis_time(Time,CS) CS%Time=increment_time(CS%Time,CS%assim_frequency*3600) call get_date(Time, yr, mon, day, hr, min, sec) - if(pe() .eq. mpp_root_pe()) print *, 'Model Time: ', yr, mon, day, hr, min, sec + if (pe() == mpp_root_pe()) print *, 'Model Time: ', yr, mon, day, hr, min, sec call get_date(CS%time, yr, mon, day, hr, min, sec) - if(pe() .eq. mpp_root_pe()) print *, 'Assimilation Time: ', yr, mon, day, hr, min, sec + if (pe() == mpp_root_pe()) print *, 'Assimilation Time: ', yr, mon, day, hr, min, sec endif if (CS%Time < Time) then call MOM_error(FATAL, " set_analysis_time: " // & diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index fe91d988ac..076dab7b56 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -324,7 +324,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset CS%En(i,j,a,fr,m) = 0.0 - if(abs(CS%En(i,j,a,fr,m))>1.0)then! only print if large + if (abs(CS%En(i,j,a,fr,m))>1.0)then! only print if large print *, 'After propagation: En<0.0 at ig=', id_g, ', jg=', jd_g print *, 'En=',CS%En(i,j,a,fr,m) print *, 'Setting En to zero' @@ -440,8 +440,8 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & Ub(i,j,fr,m) = CS%wave_structure_CSp%Uavg_profile(i,j,nzm) Umax(i,j,fr,m) = maxval(CS%wave_structure_CSp%Uavg_profile(i,j,1:nzm)) !! for debugging print profile, etc. Delete later - !if(id_g .eq. 260 .and. & - ! jd_g .eq. 50 .and. & + !if (id_g == 260 .and. & + ! jd_g == 50 .and. & ! tot_En_mode(i,j,1,1)>500.0) then ! print *, 'Profiles for mode ',m,' and frequency ',fr ! print *, 'id_g=', id_g, 'jd_g=', jd_g @@ -654,17 +654,17 @@ subroutine sum_En(G, CS, En, label) call get_time(CS%Time, seconds) days = real(seconds) * Isecs_per_day - En_sum = 0.0; + En_sum = 0.0 tmpForSumming = 0.0 do a=1,CS%nAngle tmpForSumming = global_area_mean(En(:,:,a),G)*G%areaT_global En_sum = En_sum + tmpForSumming enddo En_sum_diff = En_sum - CS%En_sum - if (CS%En_sum .ne. 0.0) then + if (CS%En_sum /= 0.0) then En_sum_pdiff= (En_sum_diff/CS%En_sum)*100.0 else - En_sum_pdiff= 0.0; + En_sum_pdiff= 0.0 endif CS%En_sum = En_sum !! Print to screen @@ -761,7 +761,7 @@ subroutine itidal_lowmode_loss(G, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, ! do a=1,CS%nAngle ! frac_per_sector = En(i,j,a,fr,m)/En_tot ! TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot - ! if(TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then + ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt ! else ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & @@ -796,10 +796,10 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) ! Arguments: ! (out) TKE_loss_sum - total energy loss rate due to specified mechanism, in W m-2. - if(mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet - if(mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet - if(mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing - if(mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet + if (mechanism == 'LeakDrag') TKE_loss_sum = CS%tot_leak_loss(i,j) ! not used for mixing yet + if (mechanism == 'QuadDrag') TKE_loss_sum = CS%tot_quad_loss(i,j) ! not used for mixing yet + if (mechanism == 'WaveDrag') TKE_loss_sum = CS%tot_itidal_loss(i,j) ! currently used for mixing + if (mechanism == 'Froude') TKE_loss_sum = CS%tot_Froude_loss(i,j) ! not used for mixing yet end subroutine get_lowmode_loss @@ -864,7 +864,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) enddo !### There should also be refraction due to cn.grad(grid_orientation). - CFL_ang(:,:,:) = 0.0; + CFL_ang(:,:,:) = 0.0 do j=js,je ! Copy En into angle space with halos. do a=1,na ; do i=is,ie @@ -923,7 +923,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) enddo; enddo ! Advect in angular space - if(.not.use_PPMang) then + if (.not.use_PPMang) then ! Use simple upwind do A=0,na ; do i=is,ie if (CFL_ang(i,j,A) > 0.0) then @@ -941,7 +941,7 @@ subroutine refract(En, cn, freq, dt, G, NAngle, use_PPMang) ! Update and copy back to En. do a=1,na ; do i=is,ie - !if(En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0)then ! for debugging + !if (En2d(i,a)+(Flux_E(i,A-1)-Flux_E(i,A)) < 0.0)then ! for debugging ! print *,"refract: OutFlux>Available" ; !stop !endif En(i,j,a) = En2d(i,a) + (Flux_E(i,A-1) - Flux_E(i,A)) @@ -1096,10 +1096,10 @@ subroutine propagate(En, cn, freq, dt, G, CS, NAngle) if (CS%corner_adv) then ! IMPLEMENT CORNER ADVECTION IN HORIZONTAL-------------------- - ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS; + ! FIND AVERAGE GROUP VELOCITY (SPEED) AT CELL CORNERS ! NOTE: THIS HAS NOT BE ADAPTED FOR REFLECTION YET (BDM)!! ! Fix indexing here later - speed(:,:) = 0; + speed(:,:) = 0 do J=jsh-1,jeh ; do I=ish-1,ieh f2 = G%CoriolisBu(I,J)**2 speed(I,J) = 0.25*(cn(i,j) + cn(i+1,j) + cn(i+1,j+1) + cn(i,j+1)) * & @@ -1199,7 +1199,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS real :: TwoPi, Angle_size real :: energized_angle ! angle through center of current wedge real :: theta ! angle at edge of wedge - real :: Nsubrays ! number of sub-rays for averaging; + real :: Nsubrays ! number of sub-rays for averaging ! count includes the two rays that bound the current wedge, ! i.e. those at -dtheta/2 and +dtheta/2 from energized angle real :: I_Nsubwedges ! inverse of number of sub-wedges @@ -1323,7 +1323,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS aW = 0.0; aSW = 0.0; aS = 0.0; ! initialize areas aSE = 0.0; aE = 0.0; aC = 0.0; ! initialize areas if (0.0 <= theta .and. theta < 0.25*TwoPi) then - xCrn = x(I-1,J-1); yCrn = y(I-1,J-1); + xCrn = x(I-1,J-1); yCrn = y(I-1,J-1) ! west area a1 = (yN - yCrn)*(0.5*(xN + xCrn)) a2 = (yCrn - yW)*(0.5*(xCrn + xW)) @@ -1349,7 +1349,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yN - yNE)*(0.5*(xN + xNE)) aC = a1 + a2 + a3 + a4 elseif (0.25*TwoPi <= theta .and. theta < 0.5*TwoPi) then - xCrn = x(I,J-1); yCrn = y(I,J-1); + xCrn = x(I,J-1); yCrn = y(I,J-1) ! south area a1 = (yCrn - yS)*(0.5*(xCrn + xS)) a2 = (yS - ySW)*(0.5*(xS + xSW)) @@ -1375,7 +1375,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yNW - yN)*(0.5*(xNW + xN)) aC = a1 + a2 + a3 + a4 elseif (0.5*TwoPi <= theta .and. theta < 0.75*TwoPi) then - xCrn = x(I,J); yCrn = y(I,J); + xCrn = x(I,J); yCrn = y(I,J) ! east area a1 = (yE - ySE)*(0.5*(xE + xSE)) a2 = (ySE - yS)*(0.5*(xSE + xS)) @@ -1401,7 +1401,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a4 = (yW - yCrn)*(0.5*(xW + xCrn)) aC = a1 + a2 + a3 + a4 elseif (0.75*TwoPi <= theta .and. theta <= 1.00*TwoPi) then - xCrn = x(I-1,J); yCrn = y(I-1,J); + xCrn = x(I-1,J); yCrn = y(I-1,J) ! north area a1 = (yNE - yE)*(0.5*(xNE + xE)) a2 = (yE - yCrn)*(0.5*(xE + xCrn)) @@ -1413,7 +1413,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS a2 = (yCrn - yW)*(0.5*(xCrn + xW)) a3 = (yW - yNW)*(0.5*(xW + xNW)) a4 = (yNW - yN)*(0.5*(xNW + xN)) - aNW = a1 + a2 + a3 + a4; + aNW = a1 + a2 + a3 + a4 ! west area a1 = (yCrn - yS)*(0.5*(xCrn + xS)) a2 = (yS - ySW)*(0.5*(xS + xSW)) @@ -1519,7 +1519,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, Nangle, CS, LB) ! Update reflected energy (Jm-2) do j=jsh,jeh ; do i=ish,ieh !do a=1,CS%nAngle - ! if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging ! print *,"propagate_x: OutFlux>Available" ; !stop ! endif !enddo @@ -1588,7 +1588,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) do j=jsh,jeh ; do i=ish,ieh Fdt_m(i,j,a) = dt*flux_y(i,J-1) ! south face influx (J) Fdt_p(i,j,a) = -dt*flux_y(i,J) ! north face influx (J) - !if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + !if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging ! print *,"propagate_y: OutFlux>Available prior to reflection" ; !stop ! print *,"flux_y_south=",flux_y(i,J-1) ! print *,"flux_y_north=",flux_y(i,J) @@ -1616,7 +1616,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, Nangle, CS, LB) ! Update reflected energy (Jm-2) do j=jsh,jeh ; do i=ish,ieh !do a=1,CS%nAngle - ! if((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging + ! if ((En(i,j,a) + G%IareaT(i,j)*(Fdt_m(i,j,a) + Fdt_p(i,j,a))) < 0.0)then ! for debugging ! print *,"propagate_y: OutFlux>Available" ; !stop ! endif !enddo @@ -1768,7 +1768,7 @@ subroutine reflect(En, NAngle, CS, G, LB) isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh - TwoPi = 8.0*atan(1.0); + TwoPi = 8.0*atan(1.0) Angle_size = TwoPi / (real(NAngle)) do a=1,NAngle @@ -1790,7 +1790,7 @@ subroutine reflect(En, NAngle, CS, G, LB) id_g = i + G%idg_offset ! redistribute energy in angular space if ray will hit boundary ! i.e., if energy is in a reflecting cell - if (angle_c(i,j) .ne. CS%nullangle) then + if (angle_c(i,j) /= CS%nullangle) then do a=1,NAngle if (En(i,j,a) > 0.0) then ! if ray is incident, keep specified boundary angle @@ -1818,7 +1818,7 @@ subroutine reflect(En, NAngle, CS, G, LB) endif a_r = nint(angle_r/Angle_size) + 1 do while (a_r > Nangle) ; a_r = a_r - Nangle ; enddo - if (a .ne. a_r) then + if (a /= a_r) then En_reflected(a_r) = part_refl(i,j)*En(i,j,a) En(i,j,a) = (1.0-part_refl(i,j))*En(i,j,a) endif @@ -2498,7 +2498,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict rms topo to 10 percent of column depth. h2(i,j) = min(0.01*G%bathyT(i,j)**2, h2(i,j)) - ! Compute the fixed part; units are [kg m-2] here; + ! Compute the fixed part; units are [kg m-2] here ! will be multiplied by N and En to get into [W m-2] CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0*& kappa_itides * h2(i,j) @@ -2516,7 +2516,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) G%domain, timelevel=1) ! replace NANs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec - if(is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle + if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle enddo ; enddo call pass_var(CS%refl_angle,G%domain) @@ -2536,7 +2536,7 @@ subroutine internal_tides_init(Time, G, GV, param_file, diag, CS) do j=jsd,jed do i=isd,ied ! flag cells with partial reflection - if (CS%refl_angle(i,j) .ne. CS%nullangle .and. & + if (CS%refl_angle(i,j) /= CS%nullangle .and. & CS%refl_pref(i,j) < 1.0 .and. CS%refl_pref(i,j) > 0.0) then CS%refl_pref_logical(i,j) = .true. endif diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 61555090ab..ecc586d025 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -22,7 +22,7 @@ module MOM_lateral_mixing_coeffs #include !> Variable mixing coefficients -type, public :: VarMix_CS ; +type, public :: VarMix_CS logical :: use_variable_mixing !< If true, use the variable mixing. logical :: Resoln_scaled_Kh !< If true, scale away the Laplacian viscosity !! when the deformation radius is well resolved. @@ -685,7 +685,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, CS, e, calculate_slopes) enddo ! k !$OMP do - do j = js,je; + do j = js,je do k=nz,CS%VarMix_Ktop,-1 ; do I=is-1,ie CS%SN_u(I,j) = CS%SN_u(I,j) + SN_u_local(I,j,k) enddo ; enddo @@ -934,10 +934,10 @@ subroutine VarMix_init(Time, G, param_file, diag, CS) "used which introduced potential restart issues. This flag will be \n"//& "deprecated in a future release.", default=.false.) if (CS%interpolate_Res_fn) then - if (CS%Res_coef_visc .ne. CS%Res_coef_khth) call MOM_error(FATAL, & + if (CS%Res_coef_visc /= CS%Res_coef_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_SCALE_COEF.") - if (CS%Res_fn_power_visc .ne. CS%Res_fn_power_khth) call MOM_error(FATAL, & + if (CS%Res_fn_power_visc /= CS%Res_fn_power_khth) call MOM_error(FATAL, & "MOM_lateral_mixing_coeffs.F90, VarMix_init:"//& "When INTERPOLATE_RES_FN=True, VISC_RES_FN_POWER must equal KH_RES_FN_POWER.") endif diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index ea8c0b3f81..4ef29b9e9d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -338,16 +338,16 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS ! depth will place a spurious depth dependence to the diagnosed KH_t. if (CS%id_KH_t > 0 .or. CS%id_KH_t1 > 0) then do k=1,nz - ! thicknesses across u and v faces, converted to 0/1 mask; + ! thicknesses across u and v faces, converted to 0/1 mask ! layer average of the interface diffusivities KH_u and KH_v do j=js,je ; do I=is-1,ie hu(I,j) = 2.0*h(i,j,k)*h(i+1,j,k)/(h(i,j,k)+h(i+1,j,k)+h_neglect) - if(hu(I,j) /= 0.0) hu(I,j) = 1.0 + if (hu(I,j) /= 0.0) hu(I,j) = 1.0 KH_u_lay(I,j) = 0.5*(KH_u(I,j,k)+KH_u(I,j,k+1)) enddo ; enddo do J=js-1,je ; do i=is,ie hv(i,J) = 2.0*h(i,j,k)*h(i,j+1,k)/(h(i,j,k)+h(i,j+1,k)+h_neglect) - if(hv(i,J) /= 0.0) hv(i,J) = 1.0 + if (hv(i,J) /= 0.0) hv(i,J) = 1.0 KH_v_lay(i,J) = 0.5*(KH_v(i,J,k)+KH_v(i,J,k+1)) enddo ; enddo ! diagnose diffusivity at T-point @@ -357,8 +357,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, MEKE, VarMix, CDp, CS / (hu(I-1,j)+hu(I,j)+hv(i,J-1)+hv(i,J)+h_neglect) enddo ; enddo enddo - if(CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) - if(CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) + if (CS%id_KH_t > 0) call post_data(CS%id_KH_t, KH_t, CS%diag) + if (CS%id_KH_t1 > 0) call post_data(CS%id_KH_t1, KH_t(:,:,1), CS%diag) endif endif @@ -1830,7 +1830,7 @@ end subroutine thickness_diffuse_init !> Deallocate the thickness diffusion control structure subroutine thickness_diffuse_end(CS) type(thickness_diffuse_CS), pointer :: CS !< Control structure for thickness diffusion - if(associated(CS)) deallocate(CS) + if (associated(CS)) deallocate(CS) end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 4b422ccf9a..2be8beee4a 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -172,7 +172,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, CS, hbl) rho_lwr(:) = 0.0; rho_1d(:) = 0.0 if (.not. associated(hbl)) then - allocate(hbl(SZI_(G), SZJ_(G))); + allocate(hbl(SZI_(G), SZJ_(G))) hbl(:,:) = 0.0 endif diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index f99a0d4dcb..2635af7fb5 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -188,7 +188,7 @@ logical function CVMix_shear_init(Time, G, GV, param_file, diag, CS) if (use_JHL) NumberTrue = NumberTrue + 1 ! After testing for interior schemes, make sure only 0 or 1 are enabled. ! Otherwise, warn user and kill job. - if ((NumberTrue).gt.1) then + if ((NumberTrue) > 1) then call MOM_error(FATAL, 'MOM_CVMix_shear_init: '// & 'Multiple shear driven internal mixing schemes selected,'//& ' please disable all but one scheme to proceed.') diff --git a/src/parameterizations/vertical/MOM_KPP.F90 b/src/parameterizations/vertical/MOM_KPP.F90 index f71cc83265..c0289bbd79 100644 --- a/src/parameterizations/vertical/MOM_KPP.F90 +++ b/src/parameterizations/vertical/MOM_KPP.F90 @@ -86,7 +86,7 @@ module MOM_KPP character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function logical :: applyNonLocalTrans !< If True, apply non-local transport to heat and scalars - logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero; + logical :: KPPzeroDiffusivity !< If True, will set diffusivity and viscosity from KPP to zero !! for testing purposes. logical :: KPPisAdditive !< If True, will add KPP diffusivity to initial diffusivity. !! If False, will replace initial diffusivity wherever KPP diffusivity @@ -303,7 +303,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) '\t MatchBoth = match gradient for both diffusivity and NLT\n'// & '\t ParabolicNonLocal = sigma*(1-sigma)^2 for diffusivity; (1-sigma)^2 for NLT', & default='SimpleShapes') - if (CS%MatchTechnique.eq.'ParabolicNonLocal') then + if (CS%MatchTechnique == 'ParabolicNonLocal') then ! This forces Cs2 (Cs in non-local computation) to equal 1 for parabolic non-local option. ! May be used during CVMix initialization. Cs_is_one=.true. @@ -486,7 +486,7 @@ logical function KPP_init(paramFile, G, diag, Time, CS, passive, Waves) CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & 'Langmuir number enhancement to Vt2 as used by [CVMix] KPP','nondim') - allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) );CS%OBLdepthprev(:,:)=0.0; + allocate( CS%OBLdepthprev( SZI_(G), SZJ_(G) ) );CS%OBLdepthprev(:,:)=0.0 if (CS%id_OBLdepth > 0) allocate( CS%OBLdepth( SZI_(G), SZJ_(G) ) ) if (CS%id_OBLdepth > 0) CS%OBLdepth(:,:) = 0. if (CS%id_BulkDrho > 0) allocate( CS%dRho( SZI_(G), SZJ_(G), SZK_(G) ) ) @@ -870,7 +870,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & endif ! apply some constraints on OBLdepth - if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value + if (CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deeper than bottom kOBL = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) @@ -945,7 +945,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! endif ! ! apply some constraints on OBLdepth - ! if(CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value + ! if (CS%fixedOBLdepth) OBLdepth_0d = CS%fixedOBLdepth_value ! OBLdepth_0d = max( OBLdepth_0d, -iFaceHeight(2) ) ! no shallower than top layer ! OBLdepth_0d = min( OBLdepth_0d, -iFaceHeight(G%ke+1) ) ! no deep than bottom ! kOBL = CVmix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, OBLdepth_0d ) @@ -960,16 +960,16 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & ! LMD94 shape function, not matching is equivalent to matching to a zero diffusivity. !BGR/ Add option for use of surface buoyancy flux with total sw flux. - if (CS%SW_METHOD .eq. SW_METHOD_ALL_SW) then + if (CS%SW_METHOD == SW_METHOD_ALL_SW) then surfBuoyFlux = buoyFlux(i,j,1) - elseif (CS%SW_METHOD .eq. SW_METHOD_MXL_SW) then + elseif (CS%SW_METHOD == SW_METHOD_MXL_SW) then surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,int(kOBL)+1) ! We know the actual buoyancy flux into the OBL - elseif (CS%SW_METHOD .eq. SW_METHOD_LV1_SW) then + elseif (CS%SW_METHOD == SW_METHOD_LV1_SW) then surfBuoyFlux = buoyFlux(i,j,1) - buoyFlux(i,j,2) endif ! If option "MatchBoth" is selected in CVMix, MOM should be capable of matching. - if (.not. (CS%MatchTechnique.eq.'MatchBoth')) then + if (.not. (CS%MatchTechnique == 'MatchBoth')) then Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt (m2/s) Kviscosity(:) = 0. ! Viscosity (m2/s) else @@ -1073,7 +1073,7 @@ subroutine KPP_calculate(CS, G, GV, h, Temp, Salt, u, v, EOS, uStar, & nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln ! set the KPP diffusivity and viscosity to zero for testing purposes - if(CS%KPPzeroDiffusivity) then + if (CS%KPPzeroDiffusivity) then Kdiffusivity(:,1) = 0.0 Kdiffusivity(:,2) = 0.0 Kviscosity(:) = 0.0 diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index c6c5a569bd..201588a2c2 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -548,7 +548,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 enddo ; enddo - if(id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) + if (id_clock_EOS>0) call cpu_clock_begin(id_clock_EOS) ! Calculate an estimate of the mid-mixed layer pressure (in Pa) do i=is,ie ; p_ref(i) = 0.0 ; enddo do k=1,CS%nkml ; do i=is,ie @@ -564,21 +564,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), is, & ie-is+1, tv%eqn_of_state) enddo - if(id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) + if (id_clock_EOS>0) call cpu_clock_end(id_clock_EOS) if (CS%ML_resort) then - if(id_clock_resort>0) call cpu_clock_begin(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) if (CS%ML_presort_nz_conv_adj > 0) & call convective_adjustment(h(:,1:), u, v, R0(:,1:), Rcv(:,1:), T(:,1:), & S(:,1:), eps, d_eb, dKE_CA, cTKE, j, G, GV, CS, & CS%ML_presort_nz_conv_adj) call sort_ML(h(:,1:), R0(:,1:), eps, G, GV, CS, ksort) - if(id_clock_resort>0) call cpu_clock_end(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) else do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo - if(id_clock_adjustment>0) call cpu_clock_begin(id_clock_adjustment) + if (id_clock_adjustment>0) call cpu_clock_begin(id_clock_adjustment) ! Undergo instantaneous entrainment into the buffer layers and mixed layers ! to remove hydrostatic instabilities. Any water that is lighter than ! currently in the mixed or buffer layer is entrained. @@ -586,7 +586,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & S(:,1:), eps, d_eb, dKE_CA, cTKE, j, G, GV, CS) do i=is,ie ; h_CA(i) = h(i,1) ; enddo - if(id_clock_adjustment>0) call cpu_clock_end(id_clock_adjustment) + if (id_clock_adjustment>0) call cpu_clock_end(id_clock_adjustment) endif if (associated(fluxes%lrunoff) .and. CS%do_rivermix) then @@ -611,7 +611,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & endif - if(id_clock_conv>0) call cpu_clock_begin(id_clock_conv) + if (id_clock_conv>0) call cpu_clock_begin(id_clock_conv) ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -635,7 +635,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & dKE_FC, j, ksort, G, GV, CS, tv, fluxes, dt, & aggregate_FW_forcing) - if(id_clock_conv>0) call cpu_clock_end(id_clock_conv) + if (id_clock_conv>0) call cpu_clock_end(id_clock_conv) ! Now the mixed layer undergoes mechanically forced entrainment. ! The mixed layer may entrain down to the Monin-Obukhov depth if the @@ -643,7 +643,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. - if(id_clock_mech>0) call cpu_clock_begin(id_clock_mech) + if (id_clock_mech>0) call cpu_clock_begin(id_clock_mech) call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & @@ -662,7 +662,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & if (CS%TKE_diagnostics) then ; do i=is,ie CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) - Idt_diag*TKE(i) enddo ; endif - if(id_clock_mech>0) call cpu_clock_end(id_clock_mech) + if (id_clock_mech>0) call cpu_clock_end(id_clock_mech) ! Calculate the homogeneous mixed layer properties and store them in layer 0. do i=is,ie ; if (htot(i) > 0.0) then @@ -692,10 +692,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! these unused layers (but not currently in the code). if (CS%ML_resort) then - if(id_clock_resort>0) call cpu_clock_begin(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_begin(id_clock_resort) call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay, eps, & d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) - if(id_clock_resort>0) call cpu_clock_end(id_clock_resort) + if (id_clock_resort>0) call cpu_clock_end(id_clock_resort) endif if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then @@ -726,7 +726,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! Move water left in the former mixed layer into the buffer layer and ! from the buffer layer into the interior. These steps might best be ! treated in conjuction. - if(id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) + if (id_clock_detrain>0) call cpu_clock_begin(id_clock_detrain) if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & GV%Rlay, dt, dt__diag, d_ea, d_eb, j, G, GV, CS, & @@ -739,7 +739,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, CS, & ! This code only works with 1 or 2 buffer layers. call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") endif - if(id_clock_detrain>0) call cpu_clock_end(id_clock_detrain) + if (id_clock_detrain>0) call cpu_clock_end(id_clock_detrain) if (CS%id_Hsfc_used > 0) then @@ -1221,7 +1221,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & dRcv_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 - if(associated(fluxes%heat_content_massin)) & + if (associated(fluxes%heat_content_massin)) & fluxes%heat_content_massin(i,j) = fluxes%heat_content_massin(i,j) & + T_precip * netMassIn(i) * GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & @@ -1274,7 +1274,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! heat_content_massout = heat_content_massout - T(i,k)*h_evap*GV%H_to_kg_m2*fluxes%C_p*Idt ! by uncommenting the lines here. ! we will also then completely remove TempXpme from the model. - if(associated(fluxes%heat_content_massout)) & + if (associated(fluxes%heat_content_massout)) & fluxes%heat_content_massout(i,j) = fluxes%heat_content_massout(i,j) & - T(i,k)*h_evap*GV%H_to_kg_m2 * fluxes%C_p * Idt if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) - & @@ -2977,7 +2977,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_det_to_h1 = h_to_bl - h_det_to_h2 h_ml_to_h1 = MAX(h_min_bl-h_det_to_h1,0.0) - Ih = 1.0/h_min_bl; + Ih = 1.0/h_min_bl Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) @@ -3868,7 +3868,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, param_file, diag, CS) if (CS%id_PE_detrain2 > 0) call safe_alloc_alloc(CS%diag_PE_detrain2, isd, ied, jsd, jed) if (CS%id_ML_depth > 0) call safe_alloc_alloc(CS%ML_depth, isd, ied, jsd, jed) - if(CS%allow_clocks_in_omp_loops) then + if (CS%allow_clocks_in_omp_loops) then id_clock_detrain = cpu_clock_id('(Ocean mixed layer detrain)', grain=CLOCK_ROUTINE) id_clock_mech = cpu_clock_id('(Ocean mixed layer mechanical entrainment)', grain=CLOCK_ROUTINE) id_clock_conv = cpu_clock_id('(Ocean mixed layer convection)', grain=CLOCK_ROUTINE) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index a4e7e47406..6eb3b854f4 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1168,7 +1168,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & enddo ! k ! Check if trying to apply fluxes over land points - elseif((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then + elseif ((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then if (.not. CS%ignore_fluxes_over_land) then call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') @@ -1203,7 +1203,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! Save temperature before increment with SW heating ! and initialize CS%penSWflux_diag to zero. - if(CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then do k=1,nz ; do i=is,ie CS%penSW_diag(i,j,k) = T2d(i,k) CS%penSWflux_diag(i,j,k) = 0.0 @@ -1235,7 +1235,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! Diagnose heating (W/m2) applied to a grid cell from SW penetration ! Also diagnose the penetrative SW heat flux at base of layer. - if(CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then + if (CS%id_penSW_diag > 0 .or. CS%id_penSWflux_diag > 0) then ! convergence of SW into a layer do k=1,nz ; do i=is,ie @@ -1248,7 +1248,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & ! CS%penSWflux_diag(i,j,k=kbot+1) is zero, since assume no SW penetrates rock. ! CS%penSWflux_diag = rsdo and CS%penSW_diag = rsdoabsorb ! rsdoabsorb(k) = rsdo(k) - rsdo(k+1), so that rsdo(k) = rsdo(k+1) + rsdoabsorb(k) - if(CS%id_penSWflux_diag > 0) then + if (CS%id_penSWflux_diag > 0) then do k=nz,1,-1 ; do i=is,ie CS%penSWflux_diag(i,j,k) = CS%penSW_diag(i,j,k) + CS%penSWflux_diag(i,j,k+1) enddo ; enddo @@ -1257,7 +1257,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, dt, fluxes, optics, h, tv, & endif ! Fill CS%nonpenSW_diag - if(CS%id_nonpenSW_diag > 0) then + if (CS%id_nonpenSW_diag > 0) then do i=is,ie CS%nonpenSW_diag(i,j) = nonpenSW(i) enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 17f363850f..0db5fbd5b3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -258,7 +258,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(inout) :: u !< zonal velocity (m/s) real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(inout) :: v !< meridional velocity (m/s) real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(inout) :: h !< thickness (m for Bouss / kg/m2 for non-Bouss) - type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields; + type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs real, dimension(:,:), pointer :: Hml !< active mixed layer depth type(forcing), intent(inout) :: fluxes !< points to forcing fields @@ -387,7 +387,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (showCallTree) call callTree_enter("diabatic(), MOM_diabatic_driver.F90") - ! Offer diagnostics of various state varables at the start of diabatic; + ! Offer diagnostics of various state varables at the start of diabatic ! these are mostly for debugging purposes. if (CS%id_u_predia > 0) call post_data(CS%id_u_predia, u, CS%diag) if (CS%id_v_predia > 0) call post_data(CS%id_v_predia, v, CS%diag) @@ -429,7 +429,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (associated(tv%T) .AND. associated(tv%frazil)) then ! For frazil diagnostic, the first call covers the first half of the time step call enable_averaging(0.5*dt, Time_end - set_time(int(floor(0.5*dt+0.5))), CS%diag) - if(CS%frazil_tendency_diag) then + if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) enddo ; enddo ; enddo @@ -732,7 +732,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! increment heat and salt diffusivity. ! CS%useKPP==.true. already has extra_T and extra_S included - if(.not. CS%useKPP) then + if (.not. CS%useKPP) then do K=2,nz ; do j=js,je ; do i=is,ie Kd_heat(i,j,K) = Kd_heat(i,j,K) + visc%Kd_extra_T(i,j,K) Kd_salt(i,j,K) = Kd_salt(i,j,K) + visc%Kd_extra_S(i,j,K) @@ -787,7 +787,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! Save fields before boundary forcing is applied for tendency diagnostics - if(CS%boundary_forcing_tendency_diag) then + if (CS%boundary_forcing_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie h_diag(i,j,k) = h(i,j,k) temp_diag(i,j,k) = tv%T(i,j,k) @@ -868,7 +868,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! diagnose the tendencies due to boundary forcing ! At this point, the diagnostic grids have not been updated since the call to the boundary layer scheme ! so all tendency diagnostics need to be posted on h_diag, and grids rebuilt afterwards - if(CS%boundary_forcing_tendency_diag) then + if (CS%boundary_forcing_tendency_diag) then call diagnose_boundary_forcing_tendency(tv, h, temp_diag, saln_diag, h_diag, dt, G, GV, CS) if (CS%id_boundary_forcing_h > 0) call post_data(CS%id_boundary_forcing_h, h, CS%diag, alt_h = h_diag) endif @@ -1094,7 +1094,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & if (associated(tv%S) .and. associated(tv%salt_deficit)) & call adjust_salt(h, tv, G, GV, CS%diabatic_aux_CSp) - if(CS%diabatic_diff_tendency_diag) then + if (CS%diabatic_diff_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) saln_diag(i,j,k) = tv%S(i,j,k) @@ -1102,7 +1102,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! Changes T and S via the tridiagonal solver; no change to h - if(CS%tracer_tridiag) then + if (CS%tracer_tridiag) then call tracer_vertdiff(hold, ea, eb, dt, tv%T, G, GV) call tracer_vertdiff(hold, ea, eb, dt, tv%S, G, GV) else @@ -1113,7 +1113,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! Note: hold here refers to the thicknesses from before the dual-entraintment when using ! the bulk mixed layer scheme. Otherwise in ALE-mode, layer thicknesses will have changed ! In either case, tendencies should be posted on hold - if(CS%diabatic_diff_tendency_diag) then + if (CS%diabatic_diff_tendency_diag) then call diagnose_diabatic_diff_tendency(tv, hold, temp_diag, saln_diag, dt, G, GV, CS) if (CS%id_diabatic_diff_h > 0) call post_data(CS%id_diabatic_diff_h, hold, CS%diag, alt_h = hold) endif @@ -1460,7 +1460,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & ! the end of the diabatic processes. if (associated(tv%T) .AND. associated(tv%frazil)) then call enable_averaging(0.5*dt, Time_end, CS%diag) - if(CS%frazil_tendency_diag) then + if (CS%frazil_tendency_diag) then do k=1,nz ; do j=js,je ; do i=is,ie temp_diag(i,j,k) = tv%T(i,j,k) enddo ; enddo ; enddo @@ -1622,19 +1622,19 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo - if(CS%id_diabatic_diff_temp_tend > 0) then + if (CS%id_diabatic_diff_temp_tend > 0) then call post_data(CS%id_diabatic_diff_temp_tend, work_3d, CS%diag, alt_h = h) endif ! heat tendency - if(CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then + if (CS%id_diabatic_diff_heat_tend > 0 .or. CS%id_diabatic_diff_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * tv%C_p * work_3d(i,j,k) enddo ; enddo ; enddo - if(CS%id_diabatic_diff_heat_tend > 0) then + if (CS%id_diabatic_diff_heat_tend > 0) then call post_data(CS%id_diabatic_diff_heat_tend, work_3d, CS%diag, alt_h = h) endif - if(CS%id_diabatic_diff_heat_tend_2d > 0) then + if (CS%id_diabatic_diff_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1646,7 +1646,7 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, endif ! salinity tendency - if(CS%id_diabatic_diff_saln_tend > 0) then + if (CS%id_diabatic_diff_saln_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1654,14 +1654,14 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, endif ! salt tendency - if(CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then + if (CS%id_diabatic_diff_salt_tend > 0 .or. CS%id_diabatic_diff_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = h(i,j,k) * GV%H_to_kg_m2 * CS%ppt2mks * work_3d(i,j,k) enddo ; enddo ; enddo - if(CS%id_diabatic_diff_salt_tend > 0) then + if (CS%id_diabatic_diff_salt_tend > 0) then call post_data(CS%id_diabatic_diff_salt_tend, work_3d, CS%diag, alt_h = h) endif - if(CS%id_diabatic_diff_salt_tend_2d > 0) then + if (CS%id_diabatic_diff_salt_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1706,7 +1706,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, work_2d(:,:) = 0.0 ! Thickness tendency - if(CS%id_boundary_forcing_h_tendency > 0) then + if (CS%id_boundary_forcing_h_tendency > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (h(i,j,k) - h_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1714,7 +1714,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! temperature tendency - if(CS%id_boundary_forcing_temp_tend > 0) then + if (CS%id_boundary_forcing_temp_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%T(i,j,k)-temp_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1722,14 +1722,14 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! heat tendency - if(CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then + if (CS%id_boundary_forcing_heat_tend > 0 .or. CS%id_boundary_forcing_heat_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = GV%H_to_kg_m2 * tv%C_p * Idt * (h(i,j,k) * tv%T(i,j,k) - h_old(i,j,k) * temp_old(i,j,k)) enddo ; enddo ; enddo - if(CS%id_boundary_forcing_heat_tend > 0) then + if (CS%id_boundary_forcing_heat_tend > 0) then call post_data(CS%id_boundary_forcing_heat_tend, work_3d, CS%diag, alt_h = h_old) endif - if(CS%id_boundary_forcing_heat_tend_2d > 0) then + if (CS%id_boundary_forcing_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1741,7 +1741,7 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! salinity tendency - if(CS%id_boundary_forcing_saln_tend > 0) then + if (CS%id_boundary_forcing_saln_tend > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = (tv%S(i,j,k)-saln_old(i,j,k))*Idt enddo ; enddo ; enddo @@ -1749,14 +1749,14 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, endif ! salt tendency - if(CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then + if (CS%id_boundary_forcing_salt_tend > 0 .or. CS%id_boundary_forcing_salt_tend_2d > 0) then do k=1,nz ; do j=js,je ; do i=is,ie work_3d(i,j,k) = GV%H_to_kg_m2 * CS%ppt2mks * Idt * (h(i,j,k) * tv%S(i,j,k) - h_old(i,j,k) * saln_old(i,j,k)) enddo ; enddo ; enddo - if(CS%id_boundary_forcing_salt_tend > 0) then + if (CS%id_boundary_forcing_salt_tend > 0) then call post_data(CS%id_boundary_forcing_salt_tend, work_3d, CS%diag, alt_h = h_old) endif - if(CS%id_boundary_forcing_salt_tend_2d > 0) then + if (CS%id_boundary_forcing_salt_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1807,7 +1807,7 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, CS) ! As a consistency check, we must have ! FRAZIL_HEAT_TENDENCY_2d = HFSIFRAZIL - if(CS%id_frazil_heat_tend_2d > 0) then + if (CS%id_frazil_heat_tend_2d > 0) then do j=js,je ; do i=is,ie work_2d(i,j) = 0.0 do k=1,nz @@ -1965,7 +1965,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_TEST", CS%int_tide_source_test, & "If true, apply an arbitrary generation site for internal tide testing", & default=.false.) - if(CS%int_tide_source_test)then + if (CS%int_tide_source_test)then call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & "X Location of generation site for internal tide", default=1.) call get_param(param_file, mod, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & @@ -1978,7 +1978,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, ! GET UNIFORM MODE VELOCITY FOR TESTING (BDM) call get_param(param_file, mod, "UNIFORM_CG", CS%uniform_cg, & "If true, set cg = cg_test everywhere for test case", default=.false.) - if(CS%uniform_cg)then + if (CS%uniform_cg)then call get_param(param_file, mod, "CG_TEST", CS%cg_test, & "Uniform group velocity of internal tide for test case", default=1.) endif @@ -2189,7 +2189,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, endif - ! diagnostics for tendencies of temp and saln due to diabatic processes; + ! diagnostics for tendencies of temp and saln due to diabatic processes ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & @@ -2261,7 +2261,7 @@ subroutine diabatic_driver_init(Time, G, GV, param_file, useALEalgorithm, diag, CS%diabatic_diff_tendency_diag = .true. endif - ! diagnostics for tendencies of thickness temp and saln due to boundary forcing; + ! diagnostics for tendencies of thickness temp and saln due to boundary forcing ! available only for ALE algorithm. ! diagnostics for tendencies of temp and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 541caccf97..89a11217fa 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -577,7 +577,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & h_neglect = GV%H_subroundoff - if(.not.CS%Use_MLD_Iteration) MAX_OBL_IT=1 + if (.not.CS%Use_MLD_Iteration) MAX_OBL_IT=1 C1_3 = 1.0 / 3.0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag IdtdR0 = 1.0 / (dt__diag * GV%Rho0) @@ -784,7 +784,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & sfc_connected(i) = .true. - if (CS%Mstar_Mode.gt.0) then + if (CS%Mstar_Mode > 0) then ! Note the value of mech_TKE(i) now must be iterated over, so it is moved here ! First solve for the TKE to PE length scale if (CS%MSTAR_MODE == CS%MLD_o_OBUKHOV) then @@ -1152,7 +1152,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & MKE_src = dMKE_max*(1.0 - exp(-Kddt_h_g0 * MKE2_Hharm)) - if (pe_chg_g0 .gt. 0.0) then + if (pe_chg_g0 > 0.0) then !Negative buoyancy (increases PE) N2_dissipation = 1.+CS%N2_DISSIPATION_SCALE_NEG else @@ -1252,7 +1252,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, CS, & ! There is not enough energy to support the mixing, so reduce the ! diffusivity to what can be supported. Kddt_h_max = Kddt_h_g0 ; Kddt_h_min = 0.0 - TKE_left_max = tot_TKE + (MKE_src - N2_DISSIPATION*PE_chg_g0) ; + TKE_left_max = tot_TKE + (MKE_src - N2_DISSIPATION*PE_chg_g0) TKE_left_min = tot_TKE ! As a starting guess, take the minimum of a false position estimate @@ -1925,7 +1925,7 @@ subroutine ust_2_u10_coare3p5(USTair,U10,GV) z0sm = 0.11 * nu / USTair; !Compute z0smooth from ustar guess u10 = USTair/sqrt(0.001); !Guess for u10 - u10a = 1000; + u10a = 1000 CT=0 do while (abs(u10a/u10-1.)>0.001) @@ -1988,7 +1988,7 @@ subroutine get_LA_windsea(ustar, hbl, GV, LA) real :: z0, z0i, r1, r2, r3, r4, tmp, us_sl, lasl_sqr_i real :: pi, u10 pi = 4.0*atan(1.0) - if (ustar .gt. 0.0) then + if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/1.225),U10,GV) ! surface Stokes drift @@ -2203,7 +2203,7 @@ subroutine energetic_PBL_init(Time, G, GV, param_file, diag, CS) "at the edge of the boundary layer as a fraction of the \n"//& "boundary layer thickness. The default is 0.1.", & units="nondim", default=0.1) - if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5).ge.0.5) then + if ( CS%USE_MLD_ITERATION .and. abs(CS%transLay_scale-0.5) >= 0.5) then call MOM_error(FATAL, "If flag USE_MLD_ITERATION is true, then "// & "EPBL_TRANSITION should be greater than 0 and less than 1.") endif diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index c225edac13..c9f10826db 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -2089,7 +2089,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & new_min_bound = .false. ! We have a new maximum bound. else ! This case would bracket a minimum. Wierd. ! Unless the derivative indicates that there is a maximum near the - ! lower bound, try keeping the end with the larger value of F; + ! lower bound, try keeping the end with the larger value of F ! in a tie keep the minimum as the answer here will be compared ! with the maximum input value later. new_min_bound = .true. diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index bfad193803..7cb7dc5dc7 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -57,7 +57,7 @@ module MOM_geothermal ! W m-2. real :: geothermal_thick ! The thickness over which geothermal heating is ! applied, in m. - logical :: apply_geothermal ! If true, geothermal heating will be applied; + logical :: apply_geothermal ! If true, geothermal heating will be applied ! otherwise GEOTHERMAL_SCALE has been set to 0 and ! there is no heat to apply. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index a573f522e4..2952d9ac9b 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -162,10 +162,10 @@ subroutine set_opacity(optics, fluxes, G, GV, CS) enddo ; enddo ; enddo else !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie ; + do j=js,je ; do i=is,ie optics%sw_pen_band(1,i,j) = (CS%SW_1st_EXP_RATIO) * fluxes%sw(i,j) optics%sw_pen_band(2,i,j) = (1.-CS%SW_1st_EXP_RATIO) * fluxes%sw(i,j) - enddo ; enddo ; + enddo ; enddo endif else do k=1,nz ; do j=js,je ; do i=is,ie ; do n=1,optics%nbands @@ -286,7 +286,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) associated(fluxes%sw_nir_dif)) chl_data(:,:) = 0.0 - if(present(chl_in)) then + if (present(chl_in)) then do j=js,je ; do i=is,ie ; chl_data(i,j) = chl_in(i,j,1) ; enddo ; enddo do k=1,nz; do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.5) .and. (chl_in(i,j,k) < 0.0)) then @@ -312,7 +312,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) endif if (CS%id_chl > 0) then - if(present(chl_in)) then + if (present(chl_in)) then call post_data(CS%id_chl, chl_in(:,:,1), CS%diag) else call post_data(CS%id_chl, chl_data, CS%diag) @@ -368,7 +368,7 @@ subroutine opacity_from_chl(optics, fluxes, G, CS, chl_in) enddo enddo ; enddo case default - call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") + call MOM_error(FATAL, "opacity_from_chl: CS%opacity_scheme is not valid.") end select !$OMP parallel do default(none) shared(nz,is,ie,js,je,CS,G,chl_in,optics,nbands) & @@ -609,12 +609,12 @@ subroutine opacity_init(Time, G, param_file, diag, tracer_flow, CS, optics) "The number of bands of penetrating shortwave radiation.", & default=1) if (CS%Opacity_scheme == DOUBLE_EXP ) then - if (optics%nbands.ne.2) then + if (optics%nbands /= 2) then call MOM_error(FATAL, "set_opacity: "// & "Cannot use a double_exp opacity scheme with nbands!=2.") endif elseif (CS%Opacity_scheme == SINGLE_EXP ) then - if (optics%nbands.ne.1) then + if (optics%nbands /= 1) then call MOM_error(FATAL, "set_opacity: "// & "Cannot use a single_exp opacity scheme with nbands!=1.") endif diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index b4b21d9e6b..a06c25b8f3 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -109,7 +109,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, CS) !! layer detrainment, in the same units as !! h - usually m or kg m-2 (i.e., H). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: eb !< The amount of fluid moved upward into a layer; + intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer !! entrainment, in the same units as h - usually !! m or kg m-2 (i.e., H). @@ -168,7 +168,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, CS) !! layer detrainment, in the same units as h - !! usually m or kg m-2 (i.e., H). real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & - intent(inout) :: eb !< The amount of fluid moved upward into a layer; + intent(inout) :: eb !< The amount of fluid moved upward into a layer !! this should be increased due to mixed layer !! entrainment, in the same units as h - usually !! m or kg m-2 (i.e., H). @@ -1062,7 +1062,7 @@ subroutine regularize_layers_init(Time, G, param_file, diag, CS) Time, 'V-point filtered 2-layer thickness deficit ratio', 'nondim') #endif - if(CS%allow_clocks_in_omp_loops) then + if (CS%allow_clocks_in_omp_loops) then id_clock_EOS = cpu_clock_id('(Ocean regularize_layers EOS)', grain=CLOCK_ROUTINE) endif id_clock_pass = cpu_clock_id('(Ocean regularize_layers halo updates)', grain=CLOCK_ROUTINE) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 6b1c219508..cc772bdb53 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -222,7 +222,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, & type(diffusivity_diags) :: dd ! structure w/ arrays of pointers to avail diags real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - T_f, S_f ! temperature and salinity (deg C and ppt); + T_f, S_f ! temperature and salinity (deg C and ppt) ! massless layers filled vertically by diffusion. real, dimension(SZI_(G),SZK_(G)) :: & @@ -1851,7 +1851,7 @@ subroutine set_diffusivity_init(Time, G, GV, param_file, diag, CS, diag_to_Z_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. - CS%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 ; + CS%Kdml = 0.0 ; CS%cdrag = 0.003 ; CS%BBL_effic = 0.0 CS%bulkmixedlayer = (GV%nkml > 0) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 5148be3379..e50d5db614 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1791,8 +1791,8 @@ subroutine set_visc_register_restarts(HI, GV, param_file, visc, restart_CS) call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & do_not_log=.true.) - use_kappa_shear = .false. ; use_CVMix_shear = .false. ; - useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. ; + use_kappa_shear = .false. ; use_CVMix_shear = .false. + useKPP = .false. ; useEPBL = .false. ; use_CVMix_conv = .false. if (.not.adiabatic) then use_kappa_shear = kappa_shear_is_used(param_file) use_CVMix_shear = CVMix_shear_is_used(param_file) diff --git a/src/parameterizations/vertical/MOM_shortwave_abs.F90 b/src/parameterizations/vertical/MOM_shortwave_abs.F90 index 1e22ba5bf9..f0695785f8 100644 --- a/src/parameterizations/vertical/MOM_shortwave_abs.F90 +++ b/src/parameterizations/vertical/MOM_shortwave_abs.F90 @@ -365,7 +365,7 @@ subroutine sumSWoverBands(G, GV, h, opacity_band, nsw, j, dt, & ! Arguments: ! (in) G = ocean grid structure ! (in) GV = The ocean's vertical grid structure. -! (in) h = layer thickness (units of m or kg/m^2); +! (in) h = layer thickness (units of m or kg/m^2) ! units of h are referred to as H below. ! (in) opacity_band = opacity in each band of penetrating shortwave ! radiation, in m-1. The indicies are band, i, k. diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 9ecf1374ef..2fc99c48fc 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -267,14 +267,14 @@ logical function tidal_mixing_init(Time, G, GV, param_file, diag, diag_to_Z_CSp, end select ! Check profile consistency - if (CS%use_CVMix_tidal .and. (CS%int_tide_profile.eq.STLAURENT_02 .or. & - CS%int_tide_profile.eq.POLZIN_09)) then + if (CS%use_CVMix_tidal .and. (CS%int_tide_profile == STLAURENT_02 .or. & + CS%int_tide_profile == POLZIN_09)) then call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profile"// & " "//trim(int_tide_profile_str)//" unavailable in CVMix. Available "//& "profiles in CVMix are "//trim(SIMMONS_PROFILE_STRING)//" and "//& trim(SCHMITTNER_PROFILE_STRING)//".") - else if (.not.CS%use_CVMix_tidal .and. (CS%int_tide_profile.eq.SIMMONS_04.or. & - CS%int_tide_profile.eq.SCHMITTNER)) then + else if (.not.CS%use_CVMix_tidal .and. (CS%int_tide_profile == SIMMONS_04.or. & + CS%int_tide_profile == SCHMITTNER)) then call MOM_error(FATAL, "tidal_mixing_init: Tidal mixing profiles "// & trim(SIMMONS_PROFILE_STRING)//" and "//trim(SCHMITTNER_PROFILE_STRING)//& " are available only when USE_CVMix_TIDAL is True.") @@ -1039,7 +1039,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, dd%Kd_lowmode_work(i,j,k) = GV%Rho0 * TKE_lowmode_lay if (associated(dd%Fl_lowmode)) dd%Fl_lowmode(i,j,k) = TKE_lowmode_rem(i) - enddo ; enddo ; + enddo ; enddo endif ! Simmons ! Polzin: @@ -1125,7 +1125,7 @@ subroutine add_int_tide_diffusivity(h, N2_bot, j, TKE_to_Kd, max_TKE, G, GV, CS, dd%Kd_lowmode_work(i,j,k) = GV%Rho0 * TKE_lowmode_lay if (associated(dd%Fl_lowmode)) dd%Fl_lowmode(i,j,k) = TKE_lowmode_rem(i) - enddo ; enddo; + enddo ; enddo endif ! Polzin end subroutine add_int_tide_diffusivity diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 62d2c98de6..38f3f4ee57 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -318,7 +318,7 @@ subroutine DOME_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, do m=1,NTR do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index d0163f2804..f3fa46210f 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -324,7 +324,7 @@ subroutine ISOMIP_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, G do m=1,NTR do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index 454521184e..fcb55382c4 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -542,14 +542,14 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC11, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC11, G, GV, sfc_flux=CFC11_flux) do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CFC12, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CFC12, G, GV, sfc_flux=CFC12_flux) diff --git a/src/tracer/MOM_OCMIP2_CO2calc.F90 b/src/tracer/MOM_OCMIP2_CO2calc.F90 index 896c70713e..8c2809418d 100644 --- a/src/tracer/MOM_OCMIP2_CO2calc.F90 +++ b/src/tracer/MOM_OCMIP2_CO2calc.F90 @@ -336,7 +336,7 @@ subroutine MOM_ocmip2_co2calc(dope_vec, mask, & ! recommended (xacc of 10**-9 drops precision to 2 significant ! figures). ! - if (mask(i,j) .ne. 0.0) then !{ + if (mask(i,j) /= 0.0) then !{ htotal(i,j) = drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, & ks, kf, bt, dic_in(i,j), ft, pt_in(i,j),& sit_in(i,j), st, ta_in(i,j), & @@ -412,7 +412,7 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, x1, fl, df) call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, x2, fh, df) -if(fl .lt. 0.0) then +if (fl < 0.0) then xl=x1 xh=x2 else @@ -428,12 +428,12 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, drtsafe, f, df) do j=1,maxit !{ - if (((drtsafe-xh)*df-f)*((drtsafe-xl)*df-f) .ge. 0.0 .or. & - abs(2.0*f) .gt. abs(dxold*df)) then + if (((drtsafe-xh)*df-f)*((drtsafe-xl)*df-f) >= 0.0 .or. & + abs(2.0*f) > abs(dxold*df)) then dxold=dx dx=0.5*(xh-xl) drtsafe=xl+dx - if (xl .eq. drtsafe) then + if (xl == drtsafe) then ! write (6,*) 'Exiting drtsafe at A on iteration ', j, ', ph = ', -log10(drtsafe) return endif @@ -442,18 +442,18 @@ function drtsafe(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & dx=f/df temp=drtsafe drtsafe=drtsafe-dx - if (temp .eq. drtsafe) then + if (temp == drtsafe) then ! write (6,*) 'Exiting drtsafe at B on iteration ', j, ', ph = ', -log10(drtsafe) return endif end if - if (abs(dx) .lt. xacc) then + if (abs(dx) < xacc) then ! write (6,*) 'Exiting drtsafe at C on iteration ', j, ', ph = ', -log10(drtsafe) return endif call ta_iter_1(k0, k1, k2, kb, k1p, k2p, k3p, ksi, kw, ks, kf, & bt, dic, ft, pt, sit, st, ta, drtsafe, f, df) - if(f .lt. 0.0) then + if (f < 0.0) then xl=drtsafe fl=f else diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 59eb49107d..65000627ef 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -178,7 +178,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Get the tracer list call generic_tracer_get_list(CS%g_tracer_list) - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ": No tracer in the list.") ! For each tracer name get its T_prog index and get its fields @@ -205,7 +205,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -260,13 +260,13 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia CS%diag=>diag !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list do - if(INDEX(CS%IC_file, '_NULL_') .ne. 0) then + if (INDEX(CS%IC_file, '_NULL_') /= 0) then call MOM_error(WARNING,"The name of the IC_file "//trim(CS%IC_file)//& " indicates no MOM initialization was asked for the generic tracers."//& "Bypassing the MOM initialization of ALL generic tracers!") @@ -279,7 +279,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(tr_ptr, g_tracer_name, CS%restart_CSp))) then - if(g_tracer%requires_src_info ) then + if (g_tracer%requires_src_info ) then call MOM_error(NOTE,"initialize_MOM_generic_tracer: "//& "initializing generic tracer "//trim(g_tracer_name)//& " using MOM_initialize_tracer_from_Z ") @@ -293,17 +293,17 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !Check/apply the bounds for each g_tracer do k=1,nk ; do j=jsc,jec ; do i=isc,iec - if(tr_ptr(i,j,k) .ne. CS%tracer_land_val) then - if(tr_ptr(i,j,k) .lt. g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then + if (tr_ptr(i,j,k) < g_tracer%src_var_valid_min) tr_ptr(i,j,k) = g_tracer%src_var_valid_min !Jasmin does not want to apply the maximum for now - !if(tr_ptr(i,j,k) .gt. g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max + !if (tr_ptr(i,j,k) > g_tracer%src_var_valid_max) tr_ptr(i,j,k) = g_tracer%src_var_valid_max endif enddo; enddo ; enddo !jgj: Reset CASED to 0 below K=1 - if(trim(g_tracer_name) .eq. 'cased') then + if (trim(g_tracer_name) == 'cased') then do k=2,nk ; do j=jsc,jec ; do i=isc,iec - if(tr_ptr(i,j,k) .ne. CS%tracer_land_val) then + if (tr_ptr(i,j,k) /= CS%tracer_land_val) then tr_ptr(i,j,k) = 0.0 endif enddo; enddo ; enddo @@ -347,7 +347,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo !! end section to re-initialize generic tracers @@ -359,7 +359,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia grid_tmask(:,:,:) = 0.0 grid_kmt(:,:) = 0 do j = G%jsd, G%jed ; do i = G%isd, G%ied - if (G%mask2dT(i,j) .gt. 0) then + if (G%mask2dT(i,j) > 0) then grid_tmask(i,j,:) = 1.0 grid_kmt(i,j) = G%ke ! Tell the code that a layer thicker than 1m is the bottom layer. endif @@ -380,7 +380,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia ! Register Z diagnostic output. !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ": No tracer in the list.") !For each tracer name get its fields g_tracer=>CS%g_tracer_list @@ -397,7 +397,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -405,16 +405,16 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, h, param_file, dia !For each special diagnostics name get its fields !Get the diag list call generic_tracer_get_diag_list(CS%g_diag_list) - if(associated(CS%g_diag_list)) then + if (associated(CS%g_diag_list)) then g_diag=>CS%g_diag_list do - if(g_diag%Z_diag .ne. 0) & + if (g_diag%Z_diag /= 0) & call register_Z_tracer(g_diag%field_ptr, trim(g_diag%name),g_diag%longname , g_diag%units, & day, G, diag_to_Z_CSp) !traverse the linked list till hit NULL g_diag=>g_diag%next - if(.NOT. associated(g_diag)) exit + if (.NOT. associated(g_diag)) exit enddo endif @@ -477,7 +477,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = G%ke !Get the tracer list - if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& + if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL,& trim(sub_name)//": No tracer in the list.") #ifdef _USE_MOM6_DIAG @@ -497,7 +497,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if(_allocated(g_tracer%trunoff)) then + if (_allocated(g_tracer%trunoff)) then call g_tracer_get_alias(g_tracer,g_tracer_name) call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) @@ -509,7 +509,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo @@ -550,14 +550,14 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, if (g_tracer_is_prog(g_tracer)) then do k=1,nk ;do j=jsc,jec ; do i=isc,iec h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, g_tracer%field(:,:,:,1), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) endif !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo endif @@ -627,7 +627,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde return endif ; endif - if(.NOT. associated(CS%g_tracer_list)) return ! No stocks. + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. m=1 ; g_tracer=>CS%g_tracer_list do @@ -646,7 +646,7 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next m = m+1 enddo @@ -692,7 +692,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg MOM_generic_tracer_min_max = 0 if (.not.associated(CS)) return - if(.NOT. associated(CS%g_tracer_list)) return ! No stocks. + if (.NOT. associated(CS%g_tracer_list)) return ! No stocks. call g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,grid_tmask=grid_tmask) @@ -725,7 +725,7 @@ function MOM_generic_tracer_min_max(ind_start, got_minmax, gmin, gmax, xgmin, yg !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next m = m+1 enddo @@ -772,7 +772,7 @@ subroutine MOM_generic_tracer_surface_state(state, h, G, CS) tau=1,sosga=sosga,model_time=get_diag_time_end(CS%diag)) !Output diagnostics via diag_manager for all tracers in this module -! if(.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& +! if (.NOT. associated(CS%g_tracer_list)) call mpp_error(FATAL, trim(sub_name)//& ! "No tracer in the list.") ! call g_tracer_send_diag(CS%g_tracer_list, get_diag_time_end(CS%diag), tau=1) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld @@ -798,7 +798,7 @@ subroutine MOM_generic_flux_init(verbosity) endif call generic_tracer_get_list(g_tracer_list) - if(.NOT. associated(g_tracer_list)) then + if (.NOT. associated(g_tracer_list)) then call mpp_error(WARNING, trim(sub_name)// ": No generic tracer in the list.") return endif @@ -810,7 +810,7 @@ subroutine MOM_generic_flux_init(verbosity) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) - if(.NOT. associated(g_tracer_next)) exit + if (.NOT. associated(g_tracer_next)) exit g_tracer=>g_tracer_next enddo diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 17a39b290c..b3232c1bca 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -445,7 +445,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) tracer => Reg%Tr(m) ! for diagnostics - if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 .or. & tracer%id_dfx_2d > 0 .or. tracer%id_dfy_2d > 0) then Idt = 1.0/dt tendency(:,:,:) = 0.0 @@ -483,7 +483,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dT(i,j)>0.) then dTracer(:) = 0. - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 k = CS%uKoL(I,j,ks) dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) k = CS%uKoR(I-1,j,ks) @@ -498,7 +498,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) enddo - if(tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then do k = 1, GV%ke tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt enddo @@ -509,11 +509,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(tracer%id_dfx_2d > 0) then + if (tracer%id_dfx_2d > 0) then do j = G%jsc,G%jec ; do I = G%isc-1,G%iec trans_x_2d(I,j) = 0. if (G%mask2dCu(I,j)>0.) then - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) enddo trans_x_2d(I,j) = trans_x_2d(I,j) * Idt @@ -524,11 +524,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. - if(tracer%id_dfy_2d > 0) then + if (tracer%id_dfy_2d > 0) then do J = G%jsc-1,G%jec ; do i = G%isc,G%iec trans_y_2d(i,J) = 0. if (G%mask2dCv(i,J)>0.) then - do ks = 1,CS%nsurf-1 ; + do ks = 1,CS%nsurf-1 trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) enddo trans_y_2d(i,J) = trans_y_2d(i,J) * Idt @@ -538,12 +538,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) endif ! post tendency of tracer content - if(tracer%id_dfxy_cont > 0) then + if (tracer%id_dfxy_cont > 0) then call post_data(tracer%id_dfxy_cont, tendency(:,:,:), CS%diag) endif ! post depth summed tendency for tracer content - if(tracer%id_dfxy_cont_2d > 0) then + if (tracer%id_dfxy_cont_2d > 0) then tendency_2d(:,:) = 0. do j = G%jsc,G%jec ; do i = G%isc,G%iec do k = 1, GV%ke @@ -556,7 +556,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, CS) ! post tendency of tracer concentration; this step must be ! done after posting tracer content tendency, since we alter ! the tendency array. - if(tracer%id_dfxy_conc > 0) then + if (tracer%id_dfxy_conc > 0) then do k = 1, GV%ke ; do j = G%jsc,G%jec ; do i = G%isc,G%iec tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + GV%H_subroundoff ) enddo ; enddo ; enddo @@ -1045,8 +1045,9 @@ subroutine find_neutral_surface_positions_discontinuous(CS, nk, ns, Pres_l, hcol bot_connected_l(:) = .false. ; bot_connected_r(:) = .false. ! Check to make sure that polynomial reconstructions were passed if refine_pos defined) - if(CS%refine_position) then - if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. present(ppoly_T_r) .and. present(ppoly_S_r) )) & + if (CS%refine_position) then + if (.not. ( present(ppoly_T_l) .and. present(ppoly_S_l) .and. & + present(ppoly_T_r) .and. present(ppoly_S_r) ) ) & call MOM_error(FATAL, "fine_neutral_surface_positions_discontinuous: refine_pos is requested, but " //& "polynomial coefficients not available for T and S") endif @@ -1447,7 +1448,7 @@ subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMe ks_top = k_sub ks_bot = k_sub + 1 - if ( Ks(ks_top) .ne. Ks(ks_bot) ) then + if ( Ks(ks_top) /= Ks(ks_bot) ) then call MOM_error(FATAL, "Neutral surfaces span more than one layer") endif kl = Ks(k_sub) @@ -1849,7 +1850,7 @@ logical function ndiff_unit_tests_discontinuous(verbose) (/0.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 0.5, 1.0, 0.0, 0.5, 1.0/), & ! pR (/0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0, 5.0, 0.0/), & ! hEff 'Right column slightly cooler') - Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) ; + Tl = (/18.,14.,10./) ; Tr = (/20.,16.,12./) call build_reconstructions_1d( remap_CS, nk, hL, Tl, poly_T_l, TiL, poly_slope, iMethod, h_neglect, h_neglect_edge ) call build_reconstructions_1d( remap_CS, nk, hR, Tr, poly_T_r, TiR, poly_slope, iMethod, h_neglect, h_neglect_edge ) call mark_unstable_cells( nk, dRdT, dRdS, Til, Sil, stable_l, ns_l ) @@ -2230,7 +2231,7 @@ logical function test_rnp(expected_pos, test_pos, title) if (test_rnp) then write(stdunit,'(A, f20.16, " .neq. ", f20.16, " <-- WRONG")') title, expected_pos, test_pos else - write(stdunit,'(A, f20.16, " .eq. ", f20.16)') title, expected_pos, test_pos + write(stdunit,'(A, f20.16, " == ", f20.16)') title, expected_pos, test_pos endif end function test_rnp !> Deallocates neutral_diffusion control structure diff --git a/src/tracer/MOM_neutral_diffusion_aux.F90 b/src/tracer/MOM_neutral_diffusion_aux.F90 index ca3435ded0..1ecfd7a25a 100644 --- a/src/tracer/MOM_neutral_diffusion_aux.F90 +++ b/src/tracer/MOM_neutral_diffusion_aux.F90 @@ -465,7 +465,7 @@ real function refine_nondim_position(CS, T_ref, S_ref, alpha_ref, beta_ref, P_to ! For the logic to find neutral surfaces to work properly, the function needs to converge to zero ! or a small negative value - if( (fb <= 0.) .and. (fb >= -CS%drho_tol) ) then + if ((fb <= 0.) .and. (fb >= -CS%drho_tol)) then refine_nondim_position = b exit endif diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 39c8385029..4c63ea2b33 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -252,7 +252,7 @@ subroutine distribute_residual_uh_barotropic(G, GV, hvol, uh) else h2d(i,k) = GV%H_subroundoff endif - enddo; enddo; + enddo; enddo ! Distribute flux. Note min/max is intended to make sure that the mass transport ! does not deplete a cell @@ -320,7 +320,7 @@ subroutine distribute_residual_vh_barotropic(G, GV, hvol, vh) else h2d(j,k) = GV%H_subroundoff endif - enddo; enddo; + enddo; enddo ! Distribute flux evenly throughout a column do j=js-1,je @@ -578,16 +578,16 @@ subroutine offline_add_diurnal_SW(fluxes, G, Time_start, Time_end) call diurnal_solar(G%geoLatT(i,j)*rad, G%geoLonT(i,j)*rad, Time_start, cosz=cosz_dt, & fracday=fracday_dt, rrsun=rrsun_dt, dt_time=dt_here) - call daily_mean_solar (G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) + call daily_mean_solar(G%geoLatT(i,j)*rad, time_since_ae, cosz_day, fracday_day, rrsun_day) diurnal_factor = cosz_dt*fracday_dt*rrsun_dt / & max(1e-30, cosz_day*fracday_day*rrsun_day) i2 = i+i_off ; j2 = j+j_off fluxes%sw(i2,j2) = fluxes%sw(i2,j2) * diurnal_factor fluxes%sw_vis_dir(i2,j2) = fluxes%sw_vis_dir(i2,j2) * diurnal_factor - fluxes%sw_vis_dif (i2,j2) = fluxes%sw_vis_dif (i2,j2) * diurnal_factor + fluxes%sw_vis_dif(i2,j2) = fluxes%sw_vis_dif(i2,j2) * diurnal_factor fluxes%sw_nir_dir(i2,j2) = fluxes%sw_nir_dir(i2,j2) * diurnal_factor - fluxes%sw_nir_dif (i2,j2) = fluxes%sw_nir_dif (i2,j2) * diurnal_factor + fluxes%sw_nir_dif(i2,j2) = fluxes%sw_nir_dif(i2,j2) * diurnal_factor enddo ; enddo end subroutine offline_add_diurnal_sw @@ -631,7 +631,7 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ integer :: i, j, k, is, ie, js, je, nz real :: Initer_vert - do_ale = .false.; + do_ale = .false. if (present(do_ale_in) ) do_ale = do_ale_in is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -707,17 +707,17 @@ subroutine update_offline_from_files(G, GV, nk_input, mean_file, sum_file, snap_ call MOM_read_data(mean_file,'sw_nir',fluxes%sw_nir_dir, G%Domain, & timelevel=ridx_sum) fluxes%sw_vis_dir(:,:) = fluxes%sw_vis_dir(:,:)*0.5 - fluxes%sw_vis_dif (:,:) = fluxes%sw_vis_dir + fluxes%sw_vis_dif(:,:) = fluxes%sw_vis_dir fluxes%sw_nir_dir(:,:) = fluxes%sw_nir_dir(:,:)*0.5 - fluxes%sw_nir_dif (:,:) = fluxes%sw_nir_dir + fluxes%sw_nir_dif(:,:) = fluxes%sw_nir_dir fluxes%sw = fluxes%sw_vis_dir + fluxes%sw_vis_dif + fluxes%sw_nir_dir + fluxes%sw_nir_dif do j=js,je ; do i=is,ie if (G%mask2dT(i,j)<1.0) then fluxes%sw(i,j) = 0.0 fluxes%sw_vis_dir(i,j) = 0.0 fluxes%sw_nir_dir(i,j) = 0.0 - fluxes%sw_vis_dif (i,j) = 0.0 - fluxes%sw_nir_dif (i,j) = 0.0 + fluxes%sw_vis_dif(i,j) = 0.0 + fluxes%sw_nir_dif(i,j) = 0.0 endif enddo ; enddo call pass_var(fluxes%sw,G%Domain) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index eed7039fe4..8da247186e 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -299,7 +299,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, CS, id_clock h_pre(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - if(CS%debug) then + if (CS%debug) then call hchksum(h_vol,"h_vol before advect",G%HI) call uvchksum("[uv]htr_sub before advect", uhtr_sub, vhtr_sub, G%HI) write(debug_msg, '(A,I4.4)') 'Before advect ', iter @@ -1032,7 +1032,7 @@ subroutine update_offline_fields(CS, h, fluxes, do_ale) if (CS%Kd_max>0.) then CS%Kd(i,j,k) = MIN(CS%Kd_max, CS%Kd(i,j,k)) endif - enddo ; enddo ; enddo ; + enddo ; enddo ; enddo do k=1,nz ; do J=js-1,je ; do i=is,ie if (CS%G%mask2dCv(i,J)<1.0) then diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 9a86d25c9c..df244cd8a4 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -319,7 +319,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & mdl = "MOM_tracer_Z_init read_Z_edges: " tr_msg = trim(tr_name)//" in "//trim(filename) - status = NF90_OPEN(filename, NF90_NOWRITE, ncid); + status = NF90_OPEN(filename, NF90_NOWRITE, ncid) if (status /= NF90_NOERR) then call MOM_error(WARNING,mdl//" Difficulties opening "//trim(filename)//& " - "//trim(NF90_STRERROR(status))) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 405c7e87d0..5c0bb7fd42 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -121,8 +121,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & max_iter = 2*INT(CEILING(dt/CS%dt)) + 1 - if(present(max_iter_in)) max_iter = max_iter_in - if(present(x_first_in)) x_first = x_first_in + if (present(max_iter_in)) max_iter = max_iter_in + if (present(x_first_in)) x_first = x_first_in call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_uhr_vhr_t_hprev, uhr, vhr, G%Domain) call create_group_pass(CS%pass_uhr_vhr_t_hprev, hprev, G%Domain) @@ -162,7 +162,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & enddo ; enddo else do i=is,ie ; do j=js,je - hprev(i,j,k) = h_prev_opt(i,j,k); + hprev(i,j,k) = h_prev_opt(i,j,k) enddo ; enddo endif enddo @@ -309,9 +309,9 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, CS, Reg, & enddo ! Iterations loop - if(present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) - if(present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) - if(present(h_out)) h_out(:,:,:) = hprev(:,:,:) + if (present(uhr_out)) uhr_out(:,:,:) = uhr(:,:,:) + if (present(vhr_out)) vhr_out(:,:,:) = vhr(:,:,:) + if (present(h_out)) h_out(:,:,:) = hprev(:,:,:) call cpu_clock_end(id_clock_advect) @@ -566,7 +566,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & segment%tr_Reg%Tr(m)%tres(I,j,k)= (1.0/fac1)*(segment%tr_Reg%Tr(m)%tres(I,j,k) + & dt*(u_L_in*Tr(m)%t(I+ishift,j,k) - & u_L_out*segment%tr_Reg%Tr(m)%t(I,j,k))) -! if (j.eq.10 .and. segment%direction==OBC_DIRECTION_E .and. m==2 .and. k.eq.1) & +! if (j == 10 .and. segment%direction==OBC_DIRECTION_E .and. m==2 .and. k == 1) & ! print *,'tres=',segment%tr_Reg%Tr(m)%tres(I,j,k),& ! segment%tr_Reg%Tr(m)%t(I,j,k), fac1 endif diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index f8762985c5..f61b5a6a5e 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -87,7 +87,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & !$OMP do do j=js,je; do i=is,ie ; sfc_src(i,j) = 0.0 ; btm_src(i,j) = 0.0 ; enddo; enddo if (present(sfc_flux)) then - if(convert_flux) then + if (convert_flux) then !$OMP do do j = js, je; do i = is,ie sfc_src(i,j) = (sfc_flux(i,j)*dt) * GV%kg_m2_to_H @@ -100,7 +100,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & endif endif if (present(btm_flux)) then - if(convert_flux) then + if (convert_flux) then !$OMP do do j = js, je; do i = is,ie btm_src(i,j) = (btm_flux(i,j)*dt) * GV%kg_m2_to_H @@ -268,12 +268,12 @@ subroutine applyTracerBoundaryFluxesInOut(G, GV, Tr, dt, fluxes, h, evap_CFL_lim if ( (.not. associated(fluxes%netMassIn)) .or. (.not. associated(fluxes%netMassOut)) ) return in_flux(:,:) = 0.0 ; out_flux(:,:) = 0.0 - if(present(in_flux_optional)) then + if (present(in_flux_optional)) then do j=js,je ; do i=is,ie in_flux(i,j) = in_flux_optional(i,j) enddo; enddo endif - if(present(out_flux_optional)) then + if (present(out_flux_optional)) then do j=js,je ; do i=is,ie out_flux(i,j) = out_flux_optional(i,j) enddo ; enddo diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index daa2062c81..2d95e8bc58 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -186,7 +186,7 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the !! character string template to use in !! labeling diagnostics - type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure; + type(MOM_restart_CS), optional, pointer :: restart_CS !< A pointer to the restart control structure !! this tracer will be registered for !! restarts if this argument is present logical, optional, intent(in) :: mandatory !< If true, this tracer must be read diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 39e6e668e3..7fb6ff8028 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -349,7 +349,7 @@ subroutine advection_test_tracer_column_physics(h_old, h_new, ea, eb, fluxes, do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index ef8abe9bbf..f320bb5716 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -284,7 +284,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,1), dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,1), G, GV) @@ -294,7 +294,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Set surface conditions do m=1,1 - if(CS%remaining_source_time>0.0) then + if (CS%remaining_source_time>0.0) then do k=1,CS%nkml ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = 1.0 enddo ; enddo ; enddo diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index dcd2b6fecb..d2cc4dafbb 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -283,7 +283,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 149b207791..e65dcdfcf4 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -243,7 +243,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) if (nz > 1) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 4f08dd7db1..0a0ad34b3f 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -378,7 +378,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index e7071f9431..b3f595f175 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -397,7 +397,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, CS do m=1,CS%ntr do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 479de3d059..06d490c835 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -278,7 +278,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do k=1,nz ;do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo; + enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%ps, dt, fluxes, h_work, & evap_CFL_limit, minimum_forcing_depth, out_flux_optional=net_salt) call tracer_vertdiff(h_work, ea, eb, dt, CS%ps, G, GV) @@ -290,7 +290,7 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G CS%diff(i,j,k) = CS%ps(i,j,k)-tv%S(i,j,k) enddo ; enddo ; enddo - if(debug) then + if (debug) then call hchksum(tv%S,"salt post pseudo-salt vertdiff", G%HI) call hchksum(CS%ps,"pseudo_salt post pseudo-salt vertdiff", G%HI) endif diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 4186c2d34d..0e9a18ffad 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -309,7 +309,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, end select ! Modify salinity and temperature when z coordinates are used - if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_ZSTAR ) then + if ( coordinateMode(verticalCoordinate) == REGRIDDING_ZSTAR ) then index_bay_z = Nint ( dome2d_depth_bay * G%ke ) do j = G%jsc,G%jec ; do i = G%isc,G%iec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon @@ -321,7 +321,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, endif ! Z initial conditions ! Modify salinity and temperature when sigma coordinates are used - if ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_SIGMA ) then + if ( coordinateMode(verticalCoordinate) == REGRIDDING_SIGMA ) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then @@ -333,8 +333,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, param_file, ! Modify temperature when rho coordinates are used T(G%isc:G%iec,G%jsc:G%jec,1:G%ke) = 0.0 - if (( coordinateMode(verticalCoordinate) .eq. REGRIDDING_RHO ) .or. & - ( coordinateMode(verticalCoordinate) .eq. REGRIDDING_LAYER )) then + if (( coordinateMode(verticalCoordinate) == REGRIDDING_RHO ) .or. & + ( coordinateMode(verticalCoordinate) == REGRIDDING_LAYER )) then do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 3e6baf1f23..7d6d5644a9 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -279,7 +279,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, param_file, tr_Reg) Def_Rad = sqrt(D_edge*g_prime_tot) / (1.0e-4*1000.0) tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5e3*Def_Rad) * GV%m_to_H - if (OBC%number_of_segments .ne. 1) then + if (OBC%number_of_segments /= 1) then print *, 'Error in DOME OBC segment setup' return !!! Need a better error message here endif diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index ed7e726f8e..a41e3b55a2 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -688,7 +688,7 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) varread1 = 'wavenumber' !Old method gives wavenumber varread2 = 'frequency' !New method gives frequency rcode_wn = NF90_OPEN(trim(SurfBandFileName), NF90_NOWRITE, ncid) - if (rcode_wn .ne. 0) then + if (rcode_wn /= 0) then call MOM_error(FATAL,"error opening file "//trim(SurfBandFileName)//& " in MOM_wave_interface.") endif @@ -696,49 +696,49 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) rcode_wn = NF90_INQ_VARID(ncid, varread1, varid_wn) rcode_fr = NF90_INQ_VARID(ncid, varread2, varid_fr) - if (rcode_wn .ne. 0 .and. rcode_fr .ne. 0) then + if (rcode_wn /= 0 .and. rcode_fr /= 0) then call MOM_error(FATAL,"error finding variable "//trim(varread1)//& " or "//trim(varread2)//" in file "//trim(SurfBandFileName)//" in MOM_wave_interface.") - elseif (rcode_wn.eq.0) then + elseif (rcode_wn == 0) then ! wavenumbers found: PartitionMode=0 rcode_wn = NF90_INQUIRE_VARIABLE(ncid, varid_wn, ndims=ndims, & dimids=dims) - if (rcode_wn .ne. 0) then + if (rcode_wn /= 0) then call MOM_error(FATAL, & 'error inquiring dimensions MOM_wave_interface.') endif rcode_wn = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode_wn .ne. 0) then + if (rcode_wn /= 0) then call MOM_error(FATAL,"error reading dimension 1 data for "// & trim(varread1)//" in file "// trim(SurfBandFileName)// & " in MOM_wave_interface.") endif rcode_wn = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode_wn .ne. 0) then + if (rcode_wn /= 0) then call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& " in file "//trim(SurfBandFileName)//" in MOM_wave_interace.") endif ! Allocating size of wavenumber bins allocate( CS%WaveNum_Cen(1:id) ) ; CS%WaveNum_Cen(:)=0.0 - elseif (rcode_fr.eq.0) then + elseif (rcode_fr == 0) then ! frequencies found: PartitionMode=1 rcode_fr = NF90_INQUIRE_VARIABLE(ncid, varid_fr, ndims=ndims, & dimids=dims) - if (rcode_fr .ne. 0) then + if (rcode_fr /= 0) then call MOM_error(FATAL,& 'error inquiring dimensions MOM_wave_interface.') endif rcode_fr = NF90_INQUIRE_DIMENSION(ncid, dims(1), dim_name(1), len=id) - if (rcode_fr .ne. 0) then + if (rcode_fr /= 0) then call MOM_error(FATAL,"error reading dimension 1 data for "// & trim(varread2)//" in file "// trim(SurfBandFileName)// & " in MOM_wave_interface.") endif rcode_fr = NF90_INQ_VARID(ncid, dim_name(1), dim_id(1)) - if (rcode_fr .ne. 0) then + if (rcode_fr /= 0) then call MOM_error(FATAL,"error finding variable "//trim(dim_name(1))//& " in file "//trim(SurfBandFileName)//" in MOM_wave_interace.") endif @@ -758,7 +758,7 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) start = 1; count = 1; count(1) = id if (PartitionMode==0) then rcode_wn = NF90_GET_VAR(ncid, dim_id(1), CS%WaveNum_Cen, start, count) - if (rcode_wn .ne. 0) then + if (rcode_wn /= 0) then call MOM_error(FATAL,& "error reading dimension 1 values for var_name "// & trim(varread1)//",dim_name "//trim(dim_name(1))// & @@ -767,7 +767,7 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) NUMBANDS = ID elseif (PartitionMode==1) then rcode_fr = NF90_GET_VAR(ncid, dim_id(1), CS%Freq_Cen, start, count) - if (rcode_fr .ne. 0) then + if (rcode_fr /= 0) then call MOM_error(FATAL,& "error reading dimension 1 values for var_name "// & trim(varread2)//",dim_name "//trim(dim_name(1))// & @@ -782,7 +782,7 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) endif do b=1,NumBands - temp_x(:,:)=0.0;temp_y(:,:)=0.0; + temp_x(:,:)=0.0;temp_y(:,:)=0.0 varname = ' ' write(varname,"(A3,I0)")'Usx',b call data_override('OCN',trim(varname), temp_x, day_center) @@ -793,7 +793,7 @@ subroutine Surface_Bands_by_data_override(day_center,G,GV,CS) call pass_vector(temp_x, temp_y, G%Domain, To_All, AGRID) !Filter land values do j = G%jsd,G%jed ; do I = G%Isd,G%Ied - if (abs(temp_x(i,j)).gt.10. .or. abs(temp_y(i,j)).gt.10. ) then + if (abs(temp_x(i,j)) > 10. .or. abs(temp_y(i,j)) > 10.) then ! Assume land-mask and zero out temp_x(i,j)=0.0 temp_y(i,j)=0.0 @@ -857,7 +857,7 @@ subroutine get_Langmuir_Number( LA, G, GV, HBL, USTAR, I, J, & Top = Bottom MidPoint = Bottom + GV%H_to_m * h(kk)/2. Bottom = Bottom + GV%H_to_m * h(kk) - if (MidPoint.gt.DPT_LASL .and. kk.gt.1 .and. ContinueLoop) then + if (MidPoint > DPT_LASL .and. kk > 1 .and. ContinueLoop) then ShearDirection = atan2(V_H(1)-V_H(kk),U_H(1)-U_H(kk)) ContinueLoop = .false. endif @@ -944,7 +944,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US_SL, LA) real :: u10 - if (ustar .gt. 0.0) then + if (ustar > 0.0) then ! Computing u10 based on u_star and COARE 3.5 relationships call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/1.225),U10,GV) ! surface Stokes drift @@ -1024,9 +1024,9 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) Top = Bottom MidPoint = Bottom - GV%H_to_m * h(kk)/2. Bottom = Bottom - GV%H_to_m * h(kk) - if (AvgDepth .lt. Bottom) then !Whole cell within H_LA + if (AvgDepth < Bottom) then !Whole cell within H_LA Sum = Sum + Profile(kk) * (GV%H_to_m * H(kk)) - elseif (AvgDepth .lt. top) then !partial cell within H_LA + elseif (AvgDepth < top) then !partial cell within H_LA Sum = Sum + Profile(kk) * (top-AvgDepth) endif enddo @@ -1101,7 +1101,7 @@ subroutine DHH85_mid(WAVES,GV, ust, zpt,US) Bnn = 1.0 Snn = 0.08 * (1.0 + 4.0 * WaveAge**3) Cnn = 1.7 - if (WA.lt. 1.) then + if (WA < 1.) then Cnn = Cnn - 6.0*log10(WA) endif !/ @@ -1142,19 +1142,19 @@ subroutine StokesMixing(G, GV, DT, h, u, v, WAVES ) do k = 1, G%ke do j = G%jscB, G%jecB do i = G%iscB, G%iecB - if (k.eq.1) then + if (k == 1) then dTauUp = 0. dTauDn = 0.5*(WAVES%Kvs(i,j,k+1)+WAVES%Kvs(i+1,j,k+1))*& (waves%us_x(i,j,k)-waves%us_x(i,j,k+1))& /(GV%H_to_m *0.5*(h(i,j,k)+h(i,j,k+1)) ) - elseif (k.lt.G%ke-1) then + elseif (k < G%ke-1) then dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k))*& (waves%us_x(i,j,k-1)-waves%us_x(i,j,k))& /(GV%H_to_m *0.5*(h(i,j,k-1)+h(i,j,k)) ) dTauDn = 0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1))*& (waves%us_x(i,j,k)-waves%us_x(i,j,k+1))& /(GV%H_to_m *0.5*(h(i,j,k)+h(i,j,k+1)) ) - elseif (k.eq.G%ke) then + elseif (k == G%ke) then dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k))*& (waves%us_x(i,j,k-1)-waves%us_x(i,j,k))& /(GV%H_to_m *0.5*(h(i,j,k-1)+h(i,j,k)) ) @@ -1169,19 +1169,19 @@ subroutine StokesMixing(G, GV, DT, h, u, v, WAVES ) do k = 1, G%ke do j = G%jscB, G%jecB do i = G%iscB, G%iecB - if (k.eq.1) then + if (k == 1) then dTauUp = 0. dTauDn = 0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1))& *(waves%us_y(i,j,k)-waves%us_y(i,j,k+1))& /(GV%H_to_m *0.5*(h(i,j,k)+h(i,j,k+1)) ) - elseif (k.lt.G%ke-1) then + elseif (k < G%ke-1) then dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k))*& (waves%us_y(i,j,k-1)-waves%us_y(i,j,k))& /(GV%H_to_m *0.5*(h(i,j,k-1)+h(i,j,k)) ) dTauDn = 0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1))*& (waves%us_y(i,j,k)-waves%us_y(i,j,k+1))& /(GV%H_to_m *0.5*(h(i,j,k)+h(i,j,k+1)) ) - elseif (k.eq.G%ke) then + elseif (k == G%ke) then dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k))*& (waves%us_y(i,j,k-1)-waves%us_y(i,j,k))& /(GV%H_to_m *0.5*(h(i,j,k-1)+h(i,j,k)) ) @@ -1252,7 +1252,7 @@ subroutine ust_2_u10_coare3p5(USTair,U10,GV) z0sm = 0.11 * nu / USTair; !Compute z0smooth from ustar guess u10 = USTair/sqrt(0.001); !Guess for u10 - u10a = 1000; + u10a = 1000 CT=0 do while (abs(u10a/u10-1.)>0.001) diff --git a/src/user/SCM_CVmix_tests.F90 b/src/user/SCM_CVmix_tests.F90 index 8795dab494..e7940f88eb 100644 --- a/src/user/SCM_CVmix_tests.F90 +++ b/src/user/SCM_CVmix_tests.F90 @@ -25,7 +25,7 @@ module SCM_CVMix_tests public SCM_CVMix_tests_CS !> Container for surface forcing parameters -type SCM_CVMix_tests_CS ; +type SCM_CVMix_tests_CS private logical :: UseWindStress !< True to use wind stress logical :: UseHeatFlux !< True to use heat flux @@ -104,13 +104,13 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, param_file, just_read_params) eta(K+1) = eta(K) - h(i,j,k)*GV%H_to_m ! Interface below layer (in m) zC = 0.5*( eta(K) + eta(K+1) ) ! Z of middle of layer (in m) DZ = min(0., zC + UpperLayerTempMLD) - if (DZ.ge.0.0) then ! in Layer 1 + if (DZ >= 0.0) then ! in Layer 1 T(i,j,k) = UpperLayerTemp else ! in Layer 2 T(i,j,k) = LowerLayerTemp + LowerLayerdTdZ * DZ endif DZ = min(0., zC + UpperLayerSaltMLD) - if (DZ.ge.0.0) then ! in Layer 1 + if (DZ >= 0.0) then ! in Layer 1 S(i,j,k) = UpperLayerSalt else ! in Layer 2 S(i,j,k) = LowerLayerSalt + LowerLayerdSdZ * DZ diff --git a/src/user/SCM_idealized_hurricane.F90 b/src/user/SCM_idealized_hurricane.F90 index 85b76c4ac5..1afa1476df 100644 --- a/src/user/SCM_idealized_hurricane.F90 +++ b/src/user/SCM_idealized_hurricane.F90 @@ -228,9 +228,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, CS) ! Calculate U10 in the interior (inside of 10x radius of maximum wind), ! while adjusting U10 to 0 outside of 12x radius of maximum wind. ! Note that rho_a is set to 1.2 following generated wind for experiment - if (r/CS%r_max.gt.0.001 .AND. r/CS%r_max.lt.10.) then + if (r/CS%r_max > 0.001 .AND. r/CS%r_max < 10.) then U10 = sqrt( A*B*dp*exp(-A/rB)/(1.2*rB) + 0.25*(rkm*f)**2 ) - 0.5*rkm*f - elseif (r/CS%r_max.gt.10. .AND. r/CS%r_max.lt.12.) then + elseif (r/CS%r_max > 10. .AND. r/CS%r_max < 12.) then r=CS%r_max*10. if (BR_Bench) then rkm = r/1000. @@ -254,9 +254,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, CS) A1 = -A0 *(0.04*RSTR +0.05*CS%tran_speed+0.14) P1 = (6.88*RSTR -9.60*CS%tran_speed+85.31)*pie/180. ALPH = A0 - A1*cos( (TRANSDIR - ADIR ) - P1) - if (r/CS%r_max.gt.10. .AND. r/CS%r_max.lt.12.) then + if (r/CS%r_max > 10. .AND. r/CS%r_max < 12.) then ALPH = ALPH* (12. - r/CS%r_max)/2. - elseif (r/CS%r_max.gt.12.) then + elseif (r/CS%r_max > 12.) then ALPH = 0.0 endif ALPH = ALPH * Deg2Rad @@ -289,9 +289,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, CS) ! Add a simple drag coefficient as a function of U10 | !/----------------------------------------------------| du10=sqrt(du**2+dv**2) - if (du10.LT.11.) then + if (du10 < 11.) then Cd = 1.2e-3 - elseif (du10.LT.20.) then + elseif (du10 < 20.) then Cd = (0.49 + 0.065 * U10 )*0.001 else Cd = 0.0018 @@ -307,9 +307,9 @@ subroutine SCM_idealized_hurricane_wind_forcing(state, forces, day, G, CS) dU = U10*sin(Adir-pie-Alph) - Uocn + U_TS dV = U10*cos(Adir-Alph) - Vocn + V_TS du10=sqrt(du**2+dv**2) - if (du10.LT.11.) then + if (du10 < 11.) then Cd = 1.2e-3 - elseif (du10.LT.20.) then + elseif (du10 < 20.) then Cd = (0.49 + 0.065 * U10 )*0.001 else Cd = 0.0018 diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 68975fc41f..c73c8a12e4 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -110,7 +110,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) - if (delta_S_strat.ne.0.) then + if (delta_S_strat /= 0.) then adjustment_delta = adjustment_deltaS / delta_S_strat * G%max_depth do k=1,nz+1 e0(k) = adjustment_delta-(G%max_depth+2*adjustment_delta) * (real(k-1) / real(nz)) @@ -128,7 +128,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par end do target_values = target_values - 1000. do j=js,je ; do i=is,ie - if (front_wave_length.ne.0.) then + if (front_wave_length /= 0.) then y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width yy = min(1.0, yy); yy = max(-1.0, yy) @@ -142,7 +142,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, param_file, just_read_par x = x * acos( 0. ) delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) do k=2,nz - if (dSdz.ne.0.) then + if (dSdz /= 0.) then eta1D(k) = ( target_values(k) - ( S_ref + delta_S ) ) / dSdz else eta1D(k) = e0(k) - (0.5*adjustment_delta) * sin( x ) @@ -258,7 +258,7 @@ subroutine adjustment_initialize_temperature_salinity ( T, S, h, G, GV, param_fi do k=nz,1,-1 eta1d(k) = eta1d(k+1) + h(i,j,k)*GV%H_to_m enddo - if (front_wave_length.ne.0.) then + if (front_wave_length /= 0.) then y = ( 0.125 + G%geoLatT(i,j) / front_wave_length ) * ( 4. * acos(0.) ) yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length yy = min(1.0, yy); yy = max(-1.0, yy) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 7a1d3dc86b..8d0506eede 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -52,7 +52,7 @@ subroutine benchmark_initialize_topography(D, G, param_file, max_depth) "The minimum depth of the ocean.", units="m", default=0.0) PI = 4.0*atan(1.0) - D0 = max_depth / 0.5; + D0 = max_depth / 0.5 ! Calculate the depth of the bottom. do i=is,ie ; do j=js,je diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 88b80e84c6..e2bc9b5869 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -344,7 +344,7 @@ subroutine dumbbell_initialize_sponges(G, GV, tv, param_file, use_ALE, CSp, ACSp S(i,j,k)=S_ref - 0.5*S_range enddo endif -! if (j.eq.G%jsc) print *,'i,Sponge S= ',i,S(i,1,1) +! if (j == G%jsc) print *,'i,Sponge S= ',i,S(i,1,1) enddo enddo diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index cdfd1fc940..fb323d571b 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -103,7 +103,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) "should have a separate boundary segment.", default=0, & do_not_log=.true.) - if (OBC%number_of_segments .lt. ntr) then + if (OBC%number_of_segments < ntr) then call MOM_error(WARNING, "Error in dyed_obc segment setup") return !!! Need a better error message here endif diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 559a9fe1a9..c4b213434f 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -55,7 +55,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) "should have a separate boundary segment.", default=0, & do_not_log=.true.) - if (OBC%number_of_segments .lt. ntr) then + if (OBC%number_of_segments < ntr) then call MOM_error(WARNING, "Error in dyed_obc segment setup") return !!! Need a better error message here endif diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 2ec735ef68..a33718b243 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -115,9 +115,9 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param x = -z_unif(k) - if ( x .le. x1 ) then - t = y1*x/x1; - else if ( (x .gt. x1 ) .and. ( x .lt. x2 )) then + if ( x <= x1 ) then + t = y1*x/x1 + else if ( (x > x1 ) .and. ( x < x2 )) then t = y1 + (y2-y1) * (x-x1) / (x2-x1) else t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) @@ -136,13 +136,13 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param weight_z = - 4.0 * ( z_unif(k) + 0.5 )**2 + 1 x = G%geoLonT(i,j) / G%len_lon - displ(k) = a0 * cos(acos(-1.0)*x) + weight_z; + displ(k) = a0 * cos(acos(-1.0)*x) + weight_z - if ( k .EQ. 1 ) then + if ( k == 1 ) then displ(k) = 0.0 end if - if ( k .EQ. nz+1 ) then + if ( k == nz+1 ) then displ(k) = 0.0 end if @@ -157,7 +157,7 @@ subroutine sloshing_initialize_thickness ( h, G, GV, param_file, just_read_param ! are strictly positive do k = nz,1,-1 - if ( z_inter(k) .LT. (z_inter(k+1) + GV%Angstrom_Z) ) then + if ( z_inter(k) < (z_inter(k+1) + GV%Angstrom_Z) ) then z_inter(k) = z_inter(k+1) + GV%Angstrom_Z end if @@ -236,7 +236,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, param_file ! S(:,:,k) = S(:,:,k-1) + delta_S !end do - deltah = G%max_depth / nz; + deltah = G%max_depth / nz do j=js,je ; do i=is,ie xi0 = 0.0 do k = 1,nz diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index bf3cd44e57..9e16775a3c 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -81,7 +81,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, h, Time) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - PI = 4.0*atan(1.0) ; + PI = 4.0*atan(1.0) if (.not.associated(OBC)) return