diff --git a/exchange/stock_constants.F90 b/exchange/stock_constants.F90 index f20687b49b..d1128feac8 100644 --- a/exchange/stock_constants.F90 +++ b/exchange/stock_constants.F90 @@ -195,7 +195,7 @@ subroutine stocks_report(Time) call get_time(Time, isec, iday) hours = iday*24 + isec/3600 - iday0*24 - isec0/3600 - days = hours/24. + days = hours/24.0_r8_kind write(stocks_file,*) '===============================================' write(stocks_file,'(a,f12.3)') 't = TimeSinceStart[days]= ',days write(stocks_file,*) '===============================================' diff --git a/exchange/xgrid.F90 b/exchange/xgrid.F90 index beb51d605d..fed75c2c81 100644 --- a/exchange/xgrid.F90 +++ b/exchange/xgrid.F90 @@ -774,7 +774,7 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u call get_variable_units(fileobj, "xgrid_area", attvalue) if( trim(attvalue) == 'm2' ) then - garea = 4.0*PI*RADIUS*RADIUS; + garea = 4.0_r8_kind * real(PI,r8_kind) * real(RADIUS,r8_kind) * real(RADIUS, r8_kind); area_tmp = tmp(:,1)/garea else if( trim(attvalue) == 'none' ) then area_tmp = tmp(:,1) @@ -873,10 +873,10 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u do l = isc, iec if(in_box_nbr(i2(l), j2(l), grid, p) ) then nsend2(p) = nsend2(p) + 1 - send_buffer(pos+1) = i1(l) - send_buffer(pos+2) = j1(l) - send_buffer(pos+3) = i2(l) - send_buffer(pos+4) = j2(l) + send_buffer(pos+1) = real(i1(l), r8_kind) + send_buffer(pos+2) = real(j1(l), r8_kind) + send_buffer(pos+3) = real(i2(l), r8_kind) + send_buffer(pos+4) = real(j2(l), r8_kind) send_buffer(pos+5) = area(l) if(use_higher_order) then send_buffer(pos+6) = di(l) @@ -891,10 +891,10 @@ subroutine load_xgrid (xmap, grid, grid_file, grid1_id, grid_id, tile1, tile2, u do l = isc, iec if(in_box_nbr(i1(l), j1(l), grid1, p)) then nsend1(p) = nsend1(p) + 1 - send_buffer(pos+1) = i1(l) - send_buffer(pos+2) = j1(l) - send_buffer(pos+3) = i2(l) - send_buffer(pos+4) = j2(l) + send_buffer(pos+1) = real(i1(l), r8_kind) + send_buffer(pos+2) = real(j1(l), r8_kind) + send_buffer(pos+3) = real(i2(l), r8_kind) + send_buffer(pos+4) = real(j2(l), r8_kind) send_buffer(pos+5) = area(l) if(use_higher_order) then send_buffer(pos+6) = di(l) @@ -2498,9 +2498,9 @@ subroutine set_comm_get1(xmap) do n = 0, npes-1 p = mod(mypos+n, npes) do l = 1, send_size(p) - send_buf(pos+1) = iarray(pos_x(p)+l) - send_buf(pos+2) = jarray(pos_x(p)+l) - send_buf(pos+3) = tarray(pos_x(p)+l) + send_buf(pos+1) = real(iarray(pos_x(p)+l), r8_kind) + send_buf(pos+2) = real(jarray(pos_x(p)+l), r8_kind) + send_buf(pos+3) = real(tarray(pos_x(p)+l), r8_kind) if(monotonic_exchange) then send_buf(pos+4) = diarray(pos_x(p)+l) send_buf(pos+5) = djarray(pos_x(p)+l) @@ -2826,9 +2826,9 @@ subroutine set_comm_put1(xmap) do n = 0, npes-1 p = mod(mypos+n, npes) do l = 1, send_size(p) - send_buf(pos+1) = iarray(pos_x(p)+l) - send_buf(pos+2) = jarray(pos_x(p)+l) - send_buf(pos+3) = tarray(pos_x(p)+l) + send_buf(pos+1) = real(iarray(pos_x(p)+l), r8_kind) + send_buf(pos+2) = real(jarray(pos_x(p)+l), r8_kind) + send_buf(pos+3) = real(tarray(pos_x(p)+l), r8_kind) if(monotonic_exchange) then send_buf(pos+4) = diarray(pos_x(p)+l) send_buf(pos+5) = djarray(pos_x(p)+l) @@ -2946,7 +2946,7 @@ subroutine regen(xmap) if(xmap%grids(g)%is_ug) then do k=1,xmap%grids(g)%km lll = xmap%grids(g)%l_index((j2-1)*xmap%grids(g)%im+i2) - if (xmap%grids(g)%frac_area(lll,1,k)/=0.0) then + if (xmap%grids(g)%frac_area(lll,1,k)/=0.0_r8_kind) then xmap%size = xmap%size+1 xmap%x1(xmap%size)%pos = xmap%ind_get1(ll) xmap%x1(xmap%size)%i = xmap%grids(g)%x(l)%i1 @@ -2965,7 +2965,7 @@ subroutine regen(xmap) enddo else do k=1,xmap%grids(g)%km - if (xmap%grids(g)%frac_area(i2,j2,k)/=0.0) then + if (xmap%grids(g)%frac_area(i2,j2,k)/=0.0_r8_kind) then xmap%size = xmap%size+1 xmap%x1(xmap%size)%pos = xmap%ind_get1(ll) xmap%x1(xmap%size)%i = xmap%grids(g)%x(l)%i1 @@ -3020,7 +3020,7 @@ subroutine regen(xmap) if(xmap%grids(g)%is_ug) then do k=1,xmap%grids(g)%km lll = xmap%grids(g)%l_index((j2-1)*xmap%grids(g)%im+i2) - if (xmap%grids(g)%frac_area(lll,1,k)/=0.0) then + if (xmap%grids(g)%frac_area(lll,1,k)/=0.0_r8_kind) then xmap%size_put1 = xmap%size_put1+1 xmap%x1_put(xmap%size_put1)%pos = xmap%ind_put1(ll) xmap%x1_put(xmap%size_put1)%i = xmap%grids(g)%x(l)%i1 @@ -3043,7 +3043,7 @@ subroutine regen(xmap) end do else do k=1,xmap%grids(g)%km - if (xmap%grids(g)%frac_area(i2,j2,k)/=0.0) then + if (xmap%grids(g)%frac_area(i2,j2,k)/=0.0_r8_kind) then xmap%size_put1 = xmap%size_put1+1 xmap%x1_put(xmap%size_put1)%pos = xmap%ind_put1(ll) xmap%x1_put(xmap%size_put1)%i = xmap%grids(g)%x(l)%i1 @@ -3092,11 +3092,11 @@ subroutine regen(xmap) xmap%get1_repro%send(n)%xLoc(pos) = xloc if( xmap%grids(g)%is_ug ) then i = xmap%grids(g)%x(l)%l2 - xloc = xloc + count(xmap%grids(g)%frac_area(i,1,:)/=0.0) + xloc = xloc + count(xmap%grids(g)%frac_area(i,1,:)/=0.0_r8_kind) else i = xmap%grids(g)%x(l)%i2 j = xmap%grids(g)%x(l)%j2 - xloc = xloc + count(xmap%grids(g)%frac_area(i,j,:)/=0.0) + xloc = xloc + count(xmap%grids(g)%frac_area(i,j,:)/=0.0_r8_kind) endif enddo enddo @@ -3318,7 +3318,7 @@ subroutine get_side1_from_xgrid(d, grid_id, x, xmap, complete) integer(i8_kind), dimension(MAX_FIELDS), save :: d_addrs=-9999 integer(i8_kind), dimension(MAX_FIELDS), save :: x_addrs=-9999 - d = 0. + d = 0.0_r8_kind if (grid_id==xmap%grids(1)%id) then is_complete = .true. if(present(complete)) is_complete=complete @@ -3467,7 +3467,7 @@ subroutine get_2_from_xgrid(d, grid, x, xmap) call mpp_clock_begin(id_get_2_from_xgrid) - d = 0.0 + d = 0.0_r8_kind do l=grid%first_get,grid%last_get d(xmap%x2_get(l)%i,xmap%x2_get(l)%j,xmap%x2_get(l)%k) = & d(xmap%x2_get(l)%i,xmap%x2_get(l)%j,xmap%x2_get(l)%k) + xmap%x2_get(l)%area*x(xmap%x2_get(l)%pos) @@ -3846,7 +3846,7 @@ subroutine get_1_from_xgrid(d_addrs, x_addrs, xmap, isize, jsize, xsize, lsize) call mpp_recv(recv_buffer(buffer_pos+1), glen=msgsize, from_pe = recv%pe, block=.false., tag=COMM_TAG_9) enddo - dg = 0.0; + dg = 0.0_r8_kind; !$OMP parallel do default(none) shared(lsize,xmap,dg,x_addrs) private(dgp,ptr_x) do l = 1, lsize ptr_x = x_addrs(l) @@ -3979,7 +3979,7 @@ subroutine get_1_from_xgrid_repro(d_addrs, x_addrs, xmap, xsize, lsize) enddo !pack the data - send_buffer(:) = 0.0 + send_buffer(:) = 0.0_r8_kind !$OMP parallel do default(none) shared(lsize,x_addrs,comm,xmap,send_buffer) & !$OMP private(ptr_x,i,j,g,l2,pos,send) do p = 1, comm%nsend @@ -4512,7 +4512,7 @@ subroutine stock_move_2d(from, to, grid_index, data, xmap, & if( .not. present(grid_index) .or. grid_index==1 ) then ! only makes sense if grid_index == 1 - from_dq = delta_t * 4.0*PI*radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1)) + from_dq = delta_t * 4.0_r8_kind*real(PI,r8_kind)*radius**2 * sum(sum(xmap%grids(1)%area * data, DIM=1)) to_dq = from_dq else @@ -4619,7 +4619,7 @@ subroutine stock_integrate_2d(data, xmap, delta_t, radius, res, ier) integer, intent(out) :: ier ier = 0 - res = 0.0 + res = 0.0_r8_kind if(.not. associated(xmap%grids) ) then ier = 6 @@ -4801,7 +4801,7 @@ subroutine get_side1_from_xgrid_ug(d, grid_id, x, xmap, complete) integer(i8_kind), dimension(MAX_FIELDS), save :: d_addrs=-9999 integer(i8_kind), dimension(MAX_FIELDS), save :: x_addrs=-9999 - d = 0. + d = 0.0_r8_kind if (grid_id==xmap%grids(1)%id) then is_complete = .true. if(present(complete)) is_complete=complete @@ -5139,7 +5139,7 @@ subroutine get_1_from_xgrid_ug(d_addrs, x_addrs, xmap, isize, xsize, lsize) call mpp_recv(recv_buffer(buffer_pos+1), glen=msgsize, from_pe = recv%pe, block=.false., tag=COMM_TAG_9) enddo - dg = 0.0; + dg = 0.0_r8_kind; !$OMP parallel do default(none) shared(lsize,xmap,dg,x_addrs) private(dgp,ptr_x) do l = 1, lsize ptr_x = x_addrs(l) @@ -5175,7 +5175,7 @@ subroutine get_1_from_xgrid_ug(d_addrs, x_addrs, xmap, isize, xsize, lsize) !--- unpack the buffer do l = 1, lsize ptr_d = d_addrs(l) - d = 0.0 + d = 0.0_r8_kind enddo !--- To bitwise reproduce old results, first copy the data onto its own pe. @@ -5284,7 +5284,7 @@ subroutine get_1_from_xgrid_ug_repro(d_addrs, x_addrs, xmap, xsize, lsize) l2 = send%xloc(n) pos = pos + 1 do k =1, xmap%grids(g)%km - if(xmap%grids(g)%frac_area(i,j,k)/=0.0) then + if(xmap%grids(g)%frac_area(i,j,k)/=0.0_r8_kind) then l2 = l2+1 send_buffer(pos) = send_buffer(pos) + xmap%x1(l2)%area *x(l2) endif diff --git a/test_fms/exchange/test_xgrid.F90 b/test_fms/exchange/test_xgrid.F90 index 820fbc301e..d9f41214f4 100644 --- a/test_fms/exchange/test_xgrid.F90 +++ b/test_fms/exchange/test_xgrid.F90 @@ -45,11 +45,11 @@ program xgrid_test use gradient_mod, only : calc_cubic_grid_info use ensemble_manager_mod, only : ensemble_manager_init, ensemble_pelist_setup use ensemble_manager_mod, only : get_ensemble_size - use platform_mod + use platform_mod, only: r8_kind, i8_kind implicit none - real(r8_kind), parameter :: EPSLN = 1.0e-10 + real(r8_kind), parameter :: EPSLN = 1.0e-10_r8_kind character(len=256) :: atm_input_file = "INPUT/atmos_input.nc" character(len=256) :: atm_output_file = "atmos_output.nc" character(len=256) :: lnd_output_file = "land_output.nc" @@ -459,14 +459,14 @@ program xgrid_test xt = 0; yt = 0; do j = jsc_atm, jec_atm do i = isc_atm, iec_atm - xt(i,j) = tmpx(2*i, 2*j)*DEG_TO_RAD - yt(i,j) = tmpy(2*i, 2*j)*DEG_TO_RAD + xt(i,j) = tmpx(2*i, 2*j)*real(DEG_TO_RAD, r8_kind) + yt(i,j) = tmpy(2*i, 2*j)*real(DEG_TO_RAD, r8_kind) end do end do do j = jsc_atm, jed_atm do i = isc_atm, ied_atm - xc(i,j) = tmpx(2*i-1, 2*j-1)*DEG_TO_RAD - yc(i,j) = tmpy(2*i-1, 2*j-1)*DEG_TO_RAD + xc(i,j) = tmpx(2*i-1, 2*j-1)*real(DEG_TO_RAD, r8_kind) + yc(i,j) = tmpy(2*i-1, 2*j-1)*real(DEG_TO_RAD, r8_kind) end do end do call mpp_update_domains(xt, atm_domain) @@ -493,7 +493,7 @@ program xgrid_test if(nk_lnd > 0 .AND. lnd_pe) then allocate(lnd_frac(isc_lnd:iec_lnd, jsc_lnd:jec_lnd, nk_lnd)) call random_number(lnd_frac) - lnd_frac = lnd_frac + 0.5 + lnd_frac = lnd_frac + 0.5_r8_kind do j = jsc_lnd, jec_lnd do i = isc_lnd, iec_lnd tot = sum(lnd_frac(i,j,:)) @@ -508,7 +508,7 @@ program xgrid_test if( ice_pe ) then allocate(ice_frac(isc_ice:iec_ice, jsc_ice:jec_ice, nk_ice)) call random_number(ice_frac) - ice_frac = ice_frac + 0.5 + ice_frac = ice_frac + 0.5_r8_kind do j = jsc_ice, jec_ice do i = isc_ice, iec_ice tot = sum(ice_frac(i,j,:))