diff --git a/CMakeLists.txt b/CMakeLists.txt index 169ca6e93..967c3be82 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -31,6 +31,12 @@ else() list(APPEND _fv3atm_defs_private NO_INLINE_POST) endif() +if(CCPP_32BIT) + add_definitions(-DCCPP_32BIT) +else() + remove_definitions(-DCCPP_32BIT) +endif() + if(NOT PARALLEL_NETCDF) list(APPEND _fv3atm_defs_private NO_PARALLEL_NETCDF) endif() diff --git a/atmos_cubed_sphere b/atmos_cubed_sphere index 0963bdec9..153cd903f 160000 --- a/atmos_cubed_sphere +++ b/atmos_cubed_sphere @@ -1 +1 @@ -Subproject commit 0963bdec95f1419af3bec38c5802554389527f36 +Subproject commit 153cd903f8f95a7bc41fb242fe96fd7cdd4c2b64 diff --git a/atmos_model.F90 b/atmos_model.F90 index 4677ea719..b4caa2aaa 100644 --- a/atmos_model.F90 +++ b/atmos_model.F90 @@ -137,14 +137,14 @@ module atmos_model_mod integer :: mlon, mlat integer :: iau_offset ! iau running window length logical :: pe ! current pe. - real(kind=8), pointer, dimension(:) :: ak, bk + real(kind=GFS_kind_phys), pointer, dimension(:) :: ak, bk real(kind=GFS_kind_phys), pointer, dimension(:,:) :: lon_bnd => null() ! local longitude axis grid box corners in radians. real(kind=GFS_kind_phys), pointer, dimension(:,:) :: lat_bnd => null() ! local latitude axis grid box corners in radians. real(kind=GFS_kind_phys), pointer, dimension(:,:) :: lon => null() ! local longitude axis grid box centers in radians. real(kind=GFS_kind_phys), pointer, dimension(:,:) :: lat => null() ! local latitude axis grid box centers in radians. real(kind=GFS_kind_phys), pointer, dimension(:,:) :: dx, dy - real(kind=8), pointer, dimension(:,:) :: area - real(kind=8), pointer, dimension(:,:,:) :: layer_hgt, level_hgt + real(kind=GFS_kind_phys), pointer, dimension(:,:) :: area + real(kind=GFS_kind_phys), pointer, dimension(:,:,:) :: layer_hgt, level_hgt type(domain2d) :: domain ! domain decomposition type(domain2d) :: domain_for_read ! domain decomposition type(time_type) :: Time ! current time @@ -467,9 +467,9 @@ subroutine atmos_timestep_diagnostics(Atmos) psum = psum + adiff if(adiff>=maxabs) then maxabs=adiff - pmaxloc(2:3) = (/ ATM_block%index(nb)%ii(i), ATM_block%index(nb)%jj(i) /) - pmaxloc(4:7) = (/ pdiff, GFS_data(nb)%Statein%pgr(i), & - GFS_data(nb)%Grid%xlat(i), GFS_data(nb)%Grid%xlon(i) /) + pmaxloc(2:3) = (/ dble(ATM_block%index(nb)%ii(i)), dble(ATM_block%index(nb)%jj(i)) /) + pmaxloc(4:7) = (/ dble(pdiff), dble(GFS_data(nb)%Statein%pgr(i)), & + dble(GFS_data(nb)%Grid%xlat(i)), dble(GFS_data(nb)%Grid%xlon(i)) /) endif enddo pcount = pcount+count @@ -2883,6 +2883,7 @@ subroutine setup_exportdata(rc) ! Instantaneous u wind (m/s) 10 m above ground case ('inst_zonal_wind_height10m') call block_data_copy(datar82d, GFS_data(nb)%coupling%u10mi_cpl, Atm_block, nb, rc=localrc) + !call block_data_copy(datar82d, GFS_data(nb)%coupling%u10mi_cpl, Atm_block, nb, rc=localrc) ! Instantaneous v wind (m/s) 10 m above ground case ('inst_merid_wind_height10m') call block_data_copy(datar82d, GFS_data(nb)%coupling%v10mi_cpl, Atm_block, nb, rc=localrc) diff --git a/ccpp/CMakeLists.txt b/ccpp/CMakeLists.txt index f204904a3..ee2b9c8b2 100644 --- a/ccpp/CMakeLists.txt +++ b/ccpp/CMakeLists.txt @@ -53,22 +53,35 @@ endif() #------------------------------------------------------------------------------ # Set flag for 32bit dynamics build if(32BIT) - message(STATUS "Compile CCPP slow physics with 64-bit precision, fast physics with 32-bit precision") + message(STATUS "Compile CCPP fast physics with 32-bit precision") add_definitions(-DOVERLOAD_R4) - if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") - set(CMAKE_Fortran_FLAGS_PHYSICS "-real-size 64") - elseif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") - set(CMAKE_Fortran_FLAGS_PHYSICS "-fdefault-real-8 -fdefault-double-8") - endif() set(CMAKE_Fortran_FLAGS_DYNAMICS "") else() - message(STATUS "Compile CCPP physics with 64-bit precision") + message(STATUS "Compile CCPP fast physics with 64-bit precision") remove_definitions(-DOVERLOAD_R8) remove_definitions(-DOVERLOAD_R4) - set(CMAKE_Fortran_FLAGS_PHYSICS "") - set(CMAKE_Fortran_FLAGS_DYNAMICS "") endif() +if(CCPP_32BIT) + message(STATUS "Compile CCPP slow physics with 32-bit precision") + add_definitions(-DSINGLE_PREC) + add_definitions(-DRTE_USE_SP) + if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") + set(CMAKE_Fortran_FLAGS_PHYSICS "-real-size 32") + elseif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") + set(CMAKE_Fortran_FLAGS_PHYSICS "-fno-default-real-8 -fdefault-double-8") + endif() +else(CCPP_32BIT) + message(STATUS "Compile CCPP slow physics with 64-bit precision") + remove_definitions(-DSINGLE_PREC) + remove_definitions(-DRTE_USE_SP) + if(CMAKE_Fortran_COMPILER_ID MATCHES "Intel") + set(CMAKE_Fortran_FLAGS_PHYSICS "-real-size 64") + elseif(CMAKE_Fortran_COMPILER_ID MATCHES "GNU") + set(CMAKE_Fortran_FLAGS_PHYSICS "-fdefault-real-8 -fdefault-double-8") + endif() +endif(CCPP_32BIT) + #------------------------------------------------------------------------------ # Add model-specific flags for C/C++/Fortran preprocessor add_definitions(-DMOIST_CAPPA -DUSE_COND -DNEMS_GSM) diff --git a/ccpp/data/GFS_typedefs.F90 b/ccpp/data/GFS_typedefs.F90 index 194bc97f4..9f939fef3 100644 --- a/ccpp/data/GFS_typedefs.F90 +++ b/ccpp/data/GFS_typedefs.F90 @@ -1,6 +1,6 @@ module GFS_typedefs - use machine, only: kind_phys, kind_dbl_prec + use machine, only: kind_phys, kind_dbl_prec, kind_sngl_prec use physcons, only: con_cp, con_fvirt, con_g, & con_hvap, con_hfus, con_pi, con_rd, con_rv, & con_t0c, con_cvap, con_cliq, con_eps, con_epsq, & @@ -2895,6 +2895,8 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & logical :: exists real(kind=kind_phys) :: tem real(kind=kind_phys) :: rinc(5) + real(kind=kind_sngl_prec) :: rinc4(5) + real(kind=kind_dbl_prec) :: rinc8(5) real(kind=kind_phys) :: wrk(1) real(kind=kind_phys), parameter :: con_hr = 3600. @@ -3385,7 +3387,11 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & ! max and min lon and lat for critical relative humidity integer :: max_lon=5000, max_lat=2000, min_lon=192, min_lat=94 real(kind=kind_phys) :: rhcmax = 0.9999999 !< max critical rel. hum. +#ifdef SINGLE_PREC + real(kind=kind_phys) :: huge = 9.9692099683868690E30 ! NetCDF float FillValue +#else real(kind=kind_phys) :: huge = 9.9692099683868690E36 ! NetCDF float FillValue +#endif !--- stochastic physics control parameters @@ -3429,6 +3435,7 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & real(kind=kind_phys) :: radar_tten_limits(2) = (/ limit_unspecified, limit_unspecified /) integer :: itime + integer :: w3kindreal,w3kindint !--- END NAMELIST VARIABLES @@ -4874,7 +4881,19 @@ subroutine control_initialize (Model, nlunit, fn_nml, me, master, & Model%cdec = -9999. Model%clstp = -9999 rinc(1:5) = 0 - call w3difdat(jdat,idat,4,rinc) + call w3kind(w3kindreal,w3kindint) + if (w3kindreal == 8) then + rinc8(1:5) = 0 + call w3difdat(jdat,idat,4,rinc8) + rinc = rinc8 + else if (w3kindreal == 4) then + rinc4(1:5) = 0 + call w3difdat(jdat,idat,4,rinc4) + rinc = rinc4 + else + write(0,*)' FATAL ERROR: Invalid w3kindreal' + call abort + endif Model%phour = rinc(4)/con_hr Model%fhour = (rinc(4) + Model%dtp)/con_hr Model%zhour = mod(Model%phour,Model%fhzero) diff --git a/ccpp/physics b/ccpp/physics index dd4911977..12c115e99 160000 --- a/ccpp/physics +++ b/ccpp/physics @@ -1 +1 @@ -Subproject commit dd49119778bbb0fea60f4aa91ad1b82923ff4d76 +Subproject commit 12c115e992d3a265eaaa67d72fcbdb3a6f21195f diff --git a/cpl/module_block_data.F90 b/cpl/module_block_data.F90 index 9d2cc9192..ff91f6633 100644 --- a/cpl/module_block_data.F90 +++ b/cpl/module_block_data.F90 @@ -1,20 +1,29 @@ module module_block_data + ! Copies block data containing real*4, real*8, or integer into + ! ESMF_KIND_R8 arrays, with an optional scaling factor. Can also + ! fill ESMF_KIND_R8 arrays with a constant value. + use ESMF, only: ESMF_KIND_R8, ESMF_SUCCESS, & ESMF_RC_PTR_NOTALLOC, ESMF_RC_VAL_OUTOFRANGE - use GFS_typedefs, only: kind_phys use block_control_mod, only: block_control_type implicit none interface block_data_copy module procedure block_copy_1d_i4_to_2d_r8 - module procedure block_copy_1d_to_2d_r8 - module procedure block_copy_2d_to_2d_r8 - module procedure block_copy_2d_to_3d_r8 - module procedure block_copy_3d_to_3d_r8 - module procedure block_copy_1dslice_to_2d_r8 - module procedure block_copy_3dslice_to_3d_r8 + module procedure block_copy_1d_r8_to_2d_r8 + module procedure block_copy_2d_r8_to_2d_r8 + module procedure block_copy_2d_r8_to_3d_r8 + module procedure block_copy_3d_r8_to_3d_r8 + module procedure block_copy_1dslice_r8_to_2d_r8 + module procedure block_copy_3dslice_r8_to_3d_r8 + module procedure block_copy_1d_r4_to_2d_r8 + module procedure block_copy_2d_r4_to_2d_r8 + module procedure block_copy_2d_r4_to_3d_r8 + module procedure block_copy_3d_r4_to_3d_r8 + module procedure block_copy_1dslice_r4_to_2d_r8 + module procedure block_copy_3dslice_r4_to_3d_r8 end interface block_data_copy interface block_data_fill @@ -23,19 +32,26 @@ module module_block_data end interface block_data_fill interface block_data_copy_or_fill - module procedure block_copy_or_fill_1d_to_2d_r8 - module procedure block_copy_or_fill_2d_to_3d_r8 - module procedure block_copy_or_fill_1dslice_to_2d_r8 + module procedure block_copy_or_fill_1d_r8_to_2d_r8 + module procedure block_copy_or_fill_2d_r8_to_3d_r8 + module procedure block_copy_or_fill_1dslice_r8_to_2d_r8 + module procedure block_copy_or_fill_1d_r4_to_2d_r8 + module procedure block_copy_or_fill_2d_r4_to_3d_r8 + module procedure block_copy_or_fill_1dslice_r4_to_2d_r8 end interface block_data_copy_or_fill interface block_data_combine_fractions - module procedure block_combine_frac_1d_to_2d_r8 + module procedure block_combine_frac_1d_r8_to_2d_r8 + module procedure block_combine_frac_1d_r4_to_2d_r8 end interface block_data_combine_fractions interface block_atmos_copy - module procedure block_array_copy_2d_to_2d_r8 - module procedure block_array_copy_3d_to_3d_r8 - module procedure block_array_copy_3dslice_to_3d_r8 + module procedure block_array_copy_2d_r8_to_2d_r8 + module procedure block_array_copy_3d_r8_to_3d_r8 + module procedure block_array_copy_3dslice_r8_to_3d_r8 + module procedure block_array_copy_2d_r4_to_2d_r8 + module procedure block_array_copy_3d_r4_to_3d_r8 + module procedure block_array_copy_3dslice_r4_to_3d_r8 end interface block_atmos_copy private @@ -58,18 +74,18 @@ subroutine block_copy_1d_i4_to_2d_r8(destin_ptr, source_ptr, block, block_index, integer, pointer :: source_ptr(:) type(block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor !$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) @@ -77,7 +93,7 @@ subroutine block_copy_1d_i4_to_2d_r8(destin_ptr, source_ptr, block, block_index, jb = block%index(block_index)%jj(ix) i = ib - block%isc + 1 j = jb - block%jsc + 1 - destin_ptr(i,j) = factor * real(source_ptr(ix), kind=kind_phys) + destin_ptr(i,j) = factor * real(source_ptr(ix), kind=8) enddo localrc = ESMF_SUCCESS end if @@ -86,25 +102,25 @@ subroutine block_copy_1d_i4_to_2d_r8(destin_ptr, source_ptr, block, block_index, end subroutine block_copy_1d_i4_to_2d_r8 - subroutine block_copy_1d_to_2d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + subroutine block_copy_1d_r8_to_2d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real(kind_phys), pointer :: source_ptr(:) + real(kind=8), pointer :: source_ptr(:) type(block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor !$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) @@ -118,33 +134,33 @@ subroutine block_copy_1d_to_2d_r8(destin_ptr, source_ptr, block, block_index, sc end if if (present(rc)) rc = localrc - - end subroutine block_copy_1d_to_2d_r8 + + end subroutine block_copy_1d_r8_to_2d_r8 ! -- copy: 1D slice to 2D - subroutine block_copy_1dslice_to_2d_r8(destin_ptr, source_ptr, slice, block, block_index, scale_factor, rc) + subroutine block_copy_1dslice_r8_to_2d_r8(destin_ptr, source_ptr, slice, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real(kind_phys), pointer :: source_ptr(:,:) + real(kind=8), pointer :: source_ptr(:,:) integer, intent(in) :: slice type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then localrc = ESMF_RC_VAL_OUTOFRANGE if (slice > 0 .and. slice <= size(source_ptr, dim=2)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor !$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) @@ -160,29 +176,29 @@ subroutine block_copy_1dslice_to_2d_r8(destin_ptr, source_ptr, slice, block, blo if (present(rc)) rc = localrc - end subroutine block_copy_1dslice_to_2d_r8 + end subroutine block_copy_1dslice_r8_to_2d_r8 ! -- copy: 2D to 3D - subroutine block_copy_2d_to_3d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + subroutine block_copy_2d_r8_to_3d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) - real(kind_phys), pointer :: source_ptr(:,:) + real(kind=8), pointer :: source_ptr(:,:) type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb, k - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor do k = 1, size(source_ptr, dim=2) !$omp parallel do private(ix,ib,jb,i,j) @@ -199,29 +215,29 @@ subroutine block_copy_2d_to_3d_r8(destin_ptr, source_ptr, block, block_index, sc if (present(rc)) rc = localrc - end subroutine block_copy_2d_to_3d_r8 + end subroutine block_copy_2d_r8_to_3d_r8 ! -- copy: 2D to 2D - subroutine block_copy_2d_to_2d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + subroutine block_copy_2d_r8_to_2d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real(kind_phys), pointer :: source_ptr(:,:) + real(kind=8), pointer :: source_ptr(:,:) type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor !$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) @@ -236,27 +252,27 @@ subroutine block_copy_2d_to_2d_r8(destin_ptr, source_ptr, block, block_index, sc if (present(rc)) rc = localrc - end subroutine block_copy_2d_to_2d_r8 + end subroutine block_copy_2d_r8_to_2d_r8 - subroutine block_array_copy_2d_to_2d_r8(destin_ptr, source_arr, block, block_index, scale_factor, rc) + subroutine block_array_copy_2d_r8_to_2d_r8(destin_ptr, source_arr, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real, intent(in) :: source_arr(:,:) + real(kind=8), intent(in) :: source_arr(:,:) type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real, optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb - real :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor !$omp parallel do private(ix,ib,jb,i,j) do ix = 1, block%blksz(block_index) @@ -271,29 +287,29 @@ subroutine block_array_copy_2d_to_2d_r8(destin_ptr, source_arr, block, block_ind if (present(rc)) rc = localrc - end subroutine block_array_copy_2d_to_2d_r8 + end subroutine block_array_copy_2d_r8_to_2d_r8 ! -- copy: 3D to 3D - subroutine block_copy_3d_to_3d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + subroutine block_copy_3d_r8_to_3d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) - real(kind_phys), pointer :: source_ptr(:,:,:) + real(kind=8), pointer :: source_ptr(:,:,:) type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb, k - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor do k = 1, size(source_ptr, dim=3) !$omp parallel do private(ix,ib,jb,i,j) @@ -310,27 +326,27 @@ subroutine block_copy_3d_to_3d_r8(destin_ptr, source_ptr, block, block_index, sc if (present(rc)) rc = localrc - end subroutine block_copy_3d_to_3d_r8 + end subroutine block_copy_3d_r8_to_3d_r8 - subroutine block_array_copy_3d_to_3d_r8(destin_ptr, source_arr, block, block_index, scale_factor, rc) + subroutine block_array_copy_3d_r8_to_3d_r8(destin_ptr, source_arr, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) - real, intent(in) :: source_arr(:,:,:) + real(kind=8), intent(in) :: source_arr(:,:,:) type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real, optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb, k - real :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor do k = 1, size(source_arr, dim=3) !$omp parallel do private(ix,ib,jb,i,j) @@ -347,32 +363,32 @@ subroutine block_array_copy_3d_to_3d_r8(destin_ptr, source_arr, block, block_ind if (present(rc)) rc = localrc - end subroutine block_array_copy_3d_to_3d_r8 + end subroutine block_array_copy_3d_r8_to_3d_r8 ! -- copy: 3D slice to 3D - subroutine block_copy_3dslice_to_3d_r8(destin_ptr, source_ptr, slice, block, block_index, scale_factor, rc) + subroutine block_copy_3dslice_r8_to_3d_r8(destin_ptr, source_ptr, slice, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) - real(kind_phys), pointer :: source_ptr(:,:,:,:) + real(kind=8), pointer :: source_ptr(:,:,:,:) integer, intent(in) :: slice type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real(kind_phys), optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb, k - real(kind_phys) :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr) .and. associated(source_ptr)) then localrc = ESMF_RC_VAL_OUTOFRANGE if (slice > 0 .and. slice <= size(source_ptr, dim=4)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor do k = 1, size(source_ptr, dim=3) !$omp parallel do private(ix,ib,jb,i,j) @@ -390,30 +406,30 @@ subroutine block_copy_3dslice_to_3d_r8(destin_ptr, source_ptr, slice, block, blo if (present(rc)) rc = localrc - end subroutine block_copy_3dslice_to_3d_r8 + end subroutine block_copy_3dslice_r8_to_3d_r8 - subroutine block_array_copy_3dslice_to_3d_r8(destin_ptr, source_arr, slice, block, block_index, scale_factor, rc) + subroutine block_array_copy_3dslice_r8_to_3d_r8(destin_ptr, source_arr, slice, block, block_index, scale_factor, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) - real, intent(in) :: source_arr(:,:,:,:) + real(kind=8), intent(in) :: source_arr(:,:,:,:) integer, intent(in) :: slice type (block_control_type), intent(in) :: block integer, intent(in) :: block_index - real, optional, intent(in) :: scale_factor + real(kind=8), optional, intent(in) :: scale_factor integer, optional, intent(out) :: rc ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb, k - real :: factor + real(kind=8) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC if (associated(destin_ptr)) then localrc = ESMF_RC_VAL_OUTOFRANGE if (slice > 0 .and. slice <= size(source_arr, dim=4)) then - factor = 1._kind_phys + factor = 1._8 if (present(scale_factor)) factor = scale_factor do k = 1, size(source_arr, dim=3) !$omp parallel do private(ix,ib,jb,i,j) @@ -431,7 +447,7 @@ subroutine block_array_copy_3dslice_to_3d_r8(destin_ptr, source_arr, slice, bloc if (present(rc)) rc = localrc - end subroutine block_array_copy_3dslice_to_3d_r8 + end subroutine block_array_copy_3dslice_r8_to_3d_r8 ! -- fill: 2D @@ -503,11 +519,477 @@ end subroutine block_fill_3d_r8 ! -- copy/fill: 1D to 2D - subroutine block_copy_or_fill_1d_to_2d_r8(destin_ptr, source_ptr, fill_value, block, block_index, rc) + subroutine block_copy_or_fill_1d_r8_to_2d_r8(destin_ptr, source_ptr, fill_value, block, block_index, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=8), pointer :: source_ptr(:) + real(ESMF_KIND_R8), intent(in) :: fill_value + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + integer, optional, intent(out) :: rc + + ! -- begin + if (present(rc)) rc = ESMF_RC_PTR_NOTALLOC + + if (associated(destin_ptr)) then + if (associated(source_ptr)) then + call block_copy_1d_r8_to_2d_r8(destin_ptr, source_ptr, block, block_index, rc=rc) + else + call block_fill_2d_r8(destin_ptr, fill_value, block, block_index, rc=rc) + end if + end if + + end subroutine block_copy_or_fill_1d_r8_to_2d_r8 + + ! -- copy/fill: 1D slice to 2D + + subroutine block_copy_or_fill_1dslice_r8_to_2d_r8(destin_ptr, source_ptr, slice, fill_value, block, block_index, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=8), pointer :: source_ptr(:,:) + integer, intent(in) :: slice + real(ESMF_KIND_R8), intent(in) :: fill_value + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + integer, optional, intent(out) :: rc + + ! -- begin + if (present(rc)) rc = ESMF_RC_PTR_NOTALLOC + + if (associated(destin_ptr)) then + if (associated(source_ptr)) then + call block_copy_1dslice_r8_to_2d_r8(destin_ptr, source_ptr, slice, block, block_index, rc=rc) + else + call block_fill_2d_r8(destin_ptr, fill_value, block, block_index, rc=rc) + end if + end if + + end subroutine block_copy_or_fill_1dslice_r8_to_2d_r8 + + ! -- copy/fill: 2D to 3D + + subroutine block_copy_or_fill_2d_r8_to_3d_r8(destin_ptr, source_ptr, fill_value, block, block_index, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) + real(kind=8), pointer :: source_ptr(:,:) + real(ESMF_KIND_R8), intent(in) :: fill_value + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + integer, optional, intent(out) :: rc + + ! -- begin + if (present(rc)) rc = ESMF_RC_PTR_NOTALLOC + + if (associated(destin_ptr)) then + if (associated(source_ptr)) then + call block_copy_2d_r8_to_3d_r8(destin_ptr, source_ptr, block, block_index, rc=rc) + else + call block_fill_3d_r8(destin_ptr, fill_value, block, block_index, rc=rc) + end if + end if + + end subroutine block_copy_or_fill_2d_r8_to_3d_r8 + + ! -- combine: 1D to 2D + + subroutine block_combine_frac_1d_r8_to_2d_r8(destin_ptr, fract1_ptr, fract2_ptr, block, block_index, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=8), pointer :: fract1_ptr(:) + real(kind=8), pointer :: fract2_ptr(:) + type(block_control_type), intent(in) :: block + integer, intent(in) :: block_index + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb + real(kind=8) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. & + associated(fract1_ptr) .and. associated(fract2_ptr)) then +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j) = fract1_ptr(ix) * (1._8 - fract2_ptr(ix)) + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_combine_frac_1d_r8_to_2d_r8 + + + ! ------------------------------------------------------------------------------------------ + + ! Real*4 Routines + + ! ------------------------------------------------------------------------------------------ + + subroutine block_copy_1d_r4_to_2d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=4), pointer :: source_ptr(:) + type(block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. associated(source_ptr)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j) = factor * source_ptr(ix) + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_copy_1d_r4_to_2d_r8 + + ! -- copy: 1D slice to 2D + + subroutine block_copy_1dslice_r4_to_2d_r8(destin_ptr, source_ptr, slice, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=4), pointer :: source_ptr(:,:) + integer, intent(in) :: slice + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. associated(source_ptr)) then + localrc = ESMF_RC_VAL_OUTOFRANGE + if (slice > 0 .and. slice <= size(source_ptr, dim=2)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j) = factor * source_ptr(ix,slice) + enddo + localrc = ESMF_SUCCESS + end if + end if + + if (present(rc)) rc = localrc + + end subroutine block_copy_1dslice_r4_to_2d_r8 + + ! -- copy: 2D to 3D + + subroutine block_copy_2d_r4_to_3d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) + real(kind=4), pointer :: source_ptr(:,:) + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb, k + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. associated(source_ptr)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor + do k = 1, size(source_ptr, dim=2) +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j,k) = factor * source_ptr(ix,k) + enddo + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_copy_2d_r4_to_3d_r8 + + ! -- copy: 2D to 2D + + subroutine block_copy_2d_r4_to_2d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=4), pointer :: source_ptr(:,:) + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. associated(source_ptr)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j) = factor * source_ptr(ib,jb) + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_copy_2d_r4_to_2d_r8 + + subroutine block_array_copy_2d_r4_to_2d_r8(destin_ptr, source_arr, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) + real(kind=4), intent(in) :: source_arr(:,:) + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j) = factor * source_arr(ib,jb) + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_array_copy_2d_r4_to_2d_r8 + + ! -- copy: 3D to 3D + + subroutine block_copy_3d_r4_to_3d_r8(destin_ptr, source_ptr, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) + real(kind=4), pointer :: source_ptr(:,:,:) + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb, k + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. associated(source_ptr)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor + do k = 1, size(source_ptr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j,k) = factor * source_ptr(ib,jb,k) + enddo + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_copy_3d_r4_to_3d_r8 + + subroutine block_array_copy_3d_r4_to_3d_r8(destin_ptr, source_arr, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) + real(kind=4), intent(in) :: source_arr(:,:,:) + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb, k + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor + do k = 1, size(source_arr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j,k) = factor * source_arr(ib,jb,k) + enddo + enddo + localrc = ESMF_SUCCESS + end if + + if (present(rc)) rc = localrc + + end subroutine block_array_copy_3d_r4_to_3d_r8 + + ! -- copy: 3D slice to 3D + + subroutine block_copy_3dslice_r4_to_3d_r8(destin_ptr, source_ptr, slice, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) + real(kind=4), pointer :: source_ptr(:,:,:,:) + integer, intent(in) :: slice + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb, k + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr) .and. associated(source_ptr)) then + localrc = ESMF_RC_VAL_OUTOFRANGE + if (slice > 0 .and. slice <= size(source_ptr, dim=4)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor + do k = 1, size(source_ptr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j,k) = factor * source_ptr(ib,jb,k,slice) + enddo + enddo + localrc = ESMF_SUCCESS + end if + end if + + if (present(rc)) rc = localrc + + end subroutine block_copy_3dslice_r4_to_3d_r8 + + subroutine block_array_copy_3dslice_r4_to_3d_r8(destin_ptr, source_arr, slice, block, block_index, scale_factor, rc) + + ! -- arguments + real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) + real(kind=4), intent(in) :: source_arr(:,:,:,:) + integer, intent(in) :: slice + type (block_control_type), intent(in) :: block + integer, intent(in) :: block_index + real(kind=4), optional, intent(in) :: scale_factor + integer, optional, intent(out) :: rc + + ! -- local variables + integer :: localrc + integer :: i, ib, ix, j, jb, k + real(kind=4) :: factor + + ! -- begin + localrc = ESMF_RC_PTR_NOTALLOC + if (associated(destin_ptr)) then + localrc = ESMF_RC_VAL_OUTOFRANGE + if (slice > 0 .and. slice <= size(source_arr, dim=4)) then + factor = 1._4 + if (present(scale_factor)) factor = scale_factor + do k = 1, size(source_arr, dim=3) +!$omp parallel do private(ix,ib,jb,i,j) + do ix = 1, block%blksz(block_index) + ib = block%index(block_index)%ii(ix) + jb = block%index(block_index)%jj(ix) + i = ib - block%isc + 1 + j = jb - block%jsc + 1 + destin_ptr(i,j,k) = factor * source_arr(ib,jb,k,slice) + enddo + enddo + localrc = ESMF_SUCCESS + end if + end if + + if (present(rc)) rc = localrc + + end subroutine block_array_copy_3dslice_r4_to_3d_r8 + + ! -- copy/fill: 1D to 2D + + subroutine block_copy_or_fill_1d_r4_to_2d_r8(destin_ptr, source_ptr, fill_value, block, block_index, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real(kind_phys), pointer :: source_ptr(:) + real(kind=4), pointer :: source_ptr(:) real(ESMF_KIND_R8), intent(in) :: fill_value type (block_control_type), intent(in) :: block integer, intent(in) :: block_index @@ -518,21 +1000,21 @@ subroutine block_copy_or_fill_1d_to_2d_r8(destin_ptr, source_ptr, fill_value, bl if (associated(destin_ptr)) then if (associated(source_ptr)) then - call block_copy_1d_to_2d_r8(destin_ptr, source_ptr, block, block_index, rc=rc) + call block_copy_1d_r4_to_2d_r8(destin_ptr, source_ptr, block, block_index, rc=rc) else call block_fill_2d_r8(destin_ptr, fill_value, block, block_index, rc=rc) end if end if - end subroutine block_copy_or_fill_1d_to_2d_r8 + end subroutine block_copy_or_fill_1d_r4_to_2d_r8 ! -- copy/fill: 1D slice to 2D - subroutine block_copy_or_fill_1dslice_to_2d_r8(destin_ptr, source_ptr, slice, fill_value, block, block_index, rc) + subroutine block_copy_or_fill_1dslice_r4_to_2d_r8(destin_ptr, source_ptr, slice, fill_value, block, block_index, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real(kind_phys), pointer :: source_ptr(:,:) + real(kind=4), pointer :: source_ptr(:,:) integer, intent(in) :: slice real(ESMF_KIND_R8), intent(in) :: fill_value type (block_control_type), intent(in) :: block @@ -544,21 +1026,21 @@ subroutine block_copy_or_fill_1dslice_to_2d_r8(destin_ptr, source_ptr, slice, fi if (associated(destin_ptr)) then if (associated(source_ptr)) then - call block_copy_1dslice_to_2d_r8(destin_ptr, source_ptr, slice, block, block_index, rc=rc) + call block_copy_1dslice_r4_to_2d_r8(destin_ptr, source_ptr, slice, block, block_index, rc=rc) else call block_fill_2d_r8(destin_ptr, fill_value, block, block_index, rc=rc) end if end if - end subroutine block_copy_or_fill_1dslice_to_2d_r8 + end subroutine block_copy_or_fill_1dslice_r4_to_2d_r8 ! -- copy/fill: 2D to 3D - subroutine block_copy_or_fill_2d_to_3d_r8(destin_ptr, source_ptr, fill_value, block, block_index, rc) + subroutine block_copy_or_fill_2d_r4_to_3d_r8(destin_ptr, source_ptr, fill_value, block, block_index, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:,:) - real(kind_phys), pointer :: source_ptr(:,:) + real(kind=4), pointer :: source_ptr(:,:) real(ESMF_KIND_R8), intent(in) :: fill_value type (block_control_type), intent(in) :: block integer, intent(in) :: block_index @@ -569,22 +1051,22 @@ subroutine block_copy_or_fill_2d_to_3d_r8(destin_ptr, source_ptr, fill_value, bl if (associated(destin_ptr)) then if (associated(source_ptr)) then - call block_copy_2d_to_3d_r8(destin_ptr, source_ptr, block, block_index, rc=rc) + call block_copy_2d_r4_to_3d_r8(destin_ptr, source_ptr, block, block_index, rc=rc) else call block_fill_3d_r8(destin_ptr, fill_value, block, block_index, rc=rc) end if end if - end subroutine block_copy_or_fill_2d_to_3d_r8 + end subroutine block_copy_or_fill_2d_r4_to_3d_r8 ! -- combine: 1D to 2D - subroutine block_combine_frac_1d_to_2d_r8(destin_ptr, fract1_ptr, fract2_ptr, block, block_index, rc) + subroutine block_combine_frac_1d_r4_to_2d_r8(destin_ptr, fract1_ptr, fract2_ptr, block, block_index, rc) ! -- arguments real(ESMF_KIND_R8), pointer :: destin_ptr(:,:) - real(kind_phys), pointer :: fract1_ptr(:) - real(kind_phys), pointer :: fract2_ptr(:) + real(kind=4), pointer :: fract1_ptr(:) + real(kind=4), pointer :: fract2_ptr(:) type(block_control_type), intent(in) :: block integer, intent(in) :: block_index integer, optional, intent(out) :: rc @@ -592,7 +1074,7 @@ subroutine block_combine_frac_1d_to_2d_r8(destin_ptr, fract1_ptr, fract2_ptr, bl ! -- local variables integer :: localrc integer :: i, ib, ix, j, jb - real(kind_phys) :: factor + real(kind=4) :: factor ! -- begin localrc = ESMF_RC_PTR_NOTALLOC @@ -604,13 +1086,13 @@ subroutine block_combine_frac_1d_to_2d_r8(destin_ptr, fract1_ptr, fract2_ptr, bl jb = block%index(block_index)%jj(ix) i = ib - block%isc + 1 j = jb - block%jsc + 1 - destin_ptr(i,j) = fract1_ptr(ix) * (1._kind_phys - fract2_ptr(ix)) + destin_ptr(i,j) = fract1_ptr(ix) * (1._4 - fract2_ptr(ix)) enddo localrc = ESMF_SUCCESS end if if (present(rc)) rc = localrc - end subroutine block_combine_frac_1d_to_2d_r8 + end subroutine block_combine_frac_1d_r4_to_2d_r8 end module module_block_data diff --git a/io/FV3GFS_io.F90 b/io/FV3GFS_io.F90 index 97d942fb3..f480d179e 100644 --- a/io/FV3GFS_io.F90 +++ b/io/FV3GFS_io.F90 @@ -2822,10 +2822,17 @@ subroutine fv3gfs_diag_output(time, diag, atm_block, nx, ny, levs, ntcw, ntoz, & integer :: i, j, k, idx, nblks, nb, ix, ii, jj integer :: is_in, js_in, isc, jsc character(len=2) :: xtra +#ifdef CCPP_32BIT + real, dimension(nx*ny) :: var2p + real, dimension(nx*ny,levs) :: var3p + real, dimension(nx,ny) :: var2 + real, dimension(nx,ny,levs) :: var3 +#else real(kind=kind_phys), dimension(nx*ny) :: var2p real(kind=kind_phys), dimension(nx*ny,levs) :: var3p real(kind=kind_phys), dimension(nx,ny) :: var2 real(kind=kind_phys), dimension(nx,ny,levs) :: var3 +#endif real(kind=kind_phys) :: rdt, rtime_int, rtime_intfull, lcnvfac real(kind=kind_phys) :: rtime_radsw, rtime_radlw logical :: used @@ -3065,7 +3072,11 @@ end subroutine fv3gfs_diag_output subroutine store_data(id, work, Time, idx, intpl_method, fldname) integer, intent(in) :: id integer, intent(in) :: idx +#ifdef CCPP_32BIT + real, intent(in) :: work(:,:) +#else real(kind=kind_phys), intent(in) :: work(ieco-isco+1,jeco-jsco+1) +#endif type(time_type), intent(in) :: Time character(*), intent(in) :: intpl_method character(*), intent(in) :: fldname @@ -3145,7 +3156,11 @@ end subroutine store_data subroutine store_data3D(id, work, Time, idx, intpl_method, fldname) integer, intent(in) :: id integer, intent(in) :: idx +#ifdef CCPP_32BIT + real, intent(in) :: work(:,:,:) +#else real(kind=kind_phys), intent(in) :: work(ieco-isco+1,jeco-jsco+1,levo) +#endif type(time_type), intent(in) :: Time character(*), intent(in) :: intpl_method character(*), intent(in) :: fldname diff --git a/module_fcst_grid_comp.F90 b/module_fcst_grid_comp.F90 index 886f23a23..a713fbeed 100644 --- a/module_fcst_grid_comp.F90 +++ b/module_fcst_grid_comp.F90 @@ -38,6 +38,8 @@ module module_fcst_grid_comp atmos_model_exchange_phase_2, & addLsmask2grid, atmos_model_get_nth_domain_info + use GFS_typedefs, only: kind_phys, kind_sngl_prec + use constants_mod, only: constants_init use fms_mod, only: error_mesg, fms_init, fms_end, & write_version_number, uppercase @@ -161,6 +163,7 @@ subroutine SetServicesNest(nest, rc) integer,dimension(2,6):: decomptile !define delayout for the 6 cubed-sphere tiles integer,dimension(2) :: regdecomp !define delayout for the nest grid type(ESMF_Decomp_Flag):: decompflagPTile(2,6) + type(ESMF_TypeKind_Flag) :: grid_typekind character(3) :: myGridStr type(ESMF_DistGrid) :: distgrid type(ESMF_Array) :: array @@ -188,6 +191,12 @@ subroutine SetServicesNest(nest, rc) call ESMF_InfoGet(info, key="layout", values=layout, rc=rc); ESMF_ERR_ABORT(rc) if (ESMF_LogFoundError(rcToCheck=rc, msg=ESMF_LOGERR_PASSTHRU, line=__LINE__, file=__FILE__)) return + if (kind_phys == kind_sngl_prec) then + grid_typekind = ESMF_TYPEKIND_R4 + else + grid_typekind = ESMF_TYPEKIND_R8 + endif + if (trim(name)=="global") then ! global domain call ESMF_InfoGet(info, key="tilesize", value=tilesize, rc=rc); ESMF_ERR_ABORT(rc) @@ -200,6 +209,7 @@ subroutine SetServicesNest(nest, rc) enddo grid = ESMF_GridCreateCubedSphere(tileSize=tilesize, & coordSys=ESMF_COORDSYS_SPH_RAD, & + coordTypeKind=grid_typekind, & regDecompPTile=decomptile, & decompflagPTile=decompflagPTile, & name="fcst_grid", rc=rc) @@ -215,6 +225,7 @@ subroutine SetServicesNest(nest, rc) maxIndex=(/nx,ny/), & gridAlign=(/-1,-1/), & coordSys=ESMF_COORDSYS_SPH_RAD, & + coordTypeKind=grid_typekind, & decompflag=(/ESMF_DECOMP_SYMMEDGEMAX,ESMF_DECOMP_SYMMEDGEMAX/), & name="fcst_grid", & indexflag=ESMF_INDEX_DELOCAL, &