From e29650866f27afdeb054a9b8a151356c4233a7b7 Mon Sep 17 00:00:00 2001 From: Sho Yokota Date: Tue, 12 Dec 2023 16:30:05 -0600 Subject: [PATCH] Add MGBF-based localization (#700) --- CMakeLists.txt | 2 + INSTALL.md | 1 + src/CMakeLists.txt | 5 + src/gsi/CMakeLists.txt | 15 + src/gsi/gsimod.F90 | 6 +- src/gsi/hybrid_ensemble_isotropic.F90 | 428 +- src/gsi/hybrid_ensemble_parameters.f90 | 5 + src/mgbf/CMakeLists.txt | 98 + src/mgbf/cmake/PackageConfig.cmake.in | 19 + src/mgbf/jp_pbfil.f90 | 1119 ++++ src/mgbf/jp_pbfil2.f90 | 1173 ++++ src/mgbf/jp_pbfil3.f90 | 2620 ++++++++ src/mgbf/jp_pietc.f90 | 111 + src/mgbf/jp_pietc_s.f90 | 113 + src/mgbf/jp_pkind.f90 | 34 + src/mgbf/jp_pkind2.f90 | 25 + src/mgbf/jp_pmat.f90 | 1096 ++++ src/mgbf/jp_pmat4.f90 | 2086 ++++++ src/mgbf/kinds.f90 | 118 + src/mgbf/mg_bocos.f90 | 8016 ++++++++++++++++++++++++ src/mgbf/mg_domain.f90 | 644 ++ src/mgbf/mg_domain_loc.f90 | 796 +++ src/mgbf/mg_entrymod.f90 | 158 + src/mgbf/mg_filtering.f90 | 1629 +++++ src/mgbf/mg_generations.f90 | 1756 ++++++ src/mgbf/mg_input.f90 | 155 + src/mgbf/mg_interpolate.f90 | 1017 +++ src/mgbf/mg_intstate.f90 | 1385 ++++ src/mgbf/mg_mppstuff.f90 | 190 + src/mgbf/mg_parameter.f90 | 934 +++ src/mgbf/mg_timers.f90 | 218 + src/mgbf/mg_transfer.f90 | 445 ++ src/mgbf/type_intstat_locpointer.inc | 44 + src/mgbf/type_intstat_point2this.inc | 83 + src/mgbf/type_parameter_locpointer.inc | 105 + src/mgbf/type_parameter_point2this.inc | 189 + 36 files changed, 26720 insertions(+), 118 deletions(-) create mode 100644 src/mgbf/CMakeLists.txt create mode 100644 src/mgbf/cmake/PackageConfig.cmake.in create mode 100644 src/mgbf/jp_pbfil.f90 create mode 100644 src/mgbf/jp_pbfil2.f90 create mode 100644 src/mgbf/jp_pbfil3.f90 create mode 100644 src/mgbf/jp_pietc.f90 create mode 100644 src/mgbf/jp_pietc_s.f90 create mode 100644 src/mgbf/jp_pkind.f90 create mode 100644 src/mgbf/jp_pkind2.f90 create mode 100644 src/mgbf/jp_pmat.f90 create mode 100644 src/mgbf/jp_pmat4.f90 create mode 100644 src/mgbf/kinds.f90 create mode 100644 src/mgbf/mg_bocos.f90 create mode 100644 src/mgbf/mg_domain.f90 create mode 100644 src/mgbf/mg_domain_loc.f90 create mode 100644 src/mgbf/mg_entrymod.f90 create mode 100644 src/mgbf/mg_filtering.f90 create mode 100644 src/mgbf/mg_generations.f90 create mode 100644 src/mgbf/mg_input.f90 create mode 100644 src/mgbf/mg_interpolate.f90 create mode 100644 src/mgbf/mg_intstate.f90 create mode 100644 src/mgbf/mg_mppstuff.f90 create mode 100644 src/mgbf/mg_parameter.f90 create mode 100644 src/mgbf/mg_timers.f90 create mode 100644 src/mgbf/mg_transfer.f90 create mode 100644 src/mgbf/type_intstat_locpointer.inc create mode 100644 src/mgbf/type_intstat_point2this.inc create mode 100644 src/mgbf/type_parameter_locpointer.inc create mode 100644 src/mgbf/type_parameter_point2this.inc diff --git a/CMakeLists.txt b/CMakeLists.txt index ac2a6a71c7..176a765262 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -29,6 +29,7 @@ endif() option(OPENMP "Enable OpenMP Threading" OFF) option(ENABLE_MKL "Use MKL for LAPACK implementation (if available)" ON) option(BUILD_GSDCLOUD "Build GSD Cloud Analysis Library" OFF) +option(BUILD_MGBF "Build MGBF Library" ON) option(BUILD_GSI "Build GSI" ON) option(BUILD_ENKF "Build EnKF" ON) option(BUILD_REG_TESTING "Build the Regression Testing Suite" OFF) @@ -37,6 +38,7 @@ option(BUILD_REG_TESTING "Build the Regression Testing Suite" OFF) message(STATUS "OPENMP ................. ${OPENMP}") message(STATUS "ENABLE_MKL ............. ${ENABLE_MKL}") message(STATUS "BUILD_GSDCLOUD ......... ${BUILD_GSDCLOUD}") +message(STATUS "BUILD_MGBF ............. ${BUILD_MGBF}") message(STATUS "BUILD_GSI .............. ${BUILD_GSI}") message(STATUS "BUILD_ENKF ............. ${BUILD_ENKF}") message(STATUS "BUILD_REG_TESTING ...... ${BUILD_REG_TESTING}") diff --git a/INSTALL.md b/INSTALL.md index 8e3187f603..eca09919c3 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -79,6 +79,7 @@ CMake allows for various options that can be specified on the command line via ` | `OPENMP` | Enable OpenMP Threading (`OFF`) | | `ENABLE_MKL` | Use MKL (`ON`), If not found use LAPACK | | `BUILD_GSDCLOUD` | Build GSD Cloud Library (`OFF`) | +| `BUILD_MGBF` | Build MGBF Library (`ON`) | | `BUILD_GSI` | Build GSI library and executable (`ON`) | | `BUILD_ENKF` | Build EnKF library and executable (`ON`) | | `BUILD_REG_TESTING` | Enable Regression Testing (`ON`) | diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index a2eb249456..2f88b978c6 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -3,6 +3,11 @@ if(BUILD_GSDCLOUD) add_subdirectory(GSD) endif() +if(BUILD_MGBF) + message(STATUS "Building MGBF library") + add_subdirectory(mgbf) +endif() + if(BUILD_GSI) message(STATUS "Building GSI") add_subdirectory(gsi) diff --git a/src/gsi/CMakeLists.txt b/src/gsi/CMakeLists.txt index af94224c05..f894b0a8a8 100644 --- a/src/gsi/CMakeLists.txt +++ b/src/gsi/CMakeLists.txt @@ -29,6 +29,7 @@ endif() option(OPENMP "Enable OpenMP Threading" OFF) option(ENABLE_MKL "Use MKL for LAPACK implementation (if available)" ON) option(USE_GSDCLOUD "Use GSD Cloud Analysis library" OFF) +option(USE_MGBF "Use MGBF library" ON) set(GSI_VALID_MODES "GFS" "Regional") set(GSI_MODE "GFS" CACHE STRING "Choose the GSI Application.") @@ -43,6 +44,7 @@ endif() message(STATUS "GSI: OPENMP ................. ${OPENMP}") message(STATUS "GSI: ENABLE_MKL ............. ${ENABLE_MKL}") message(STATUS "GSI: USE_GSDCLOUD ........... ${USE_GSDCLOUD}") +message(STATUS "GSI: USE_MGBF ............... ${USE_MGBF}") message(STATUS "GSI: GSI_MODE ............... ${GSI_MODE}") # Dependencies @@ -87,6 +89,13 @@ if(USE_GSDCLOUD) endif() endif() +# MGBF library dependency +if(USE_MGBF) + if(NOT TARGET mgbf) + find_package(mgbf REQUIRED) + endif() +endif() + # Get compiler flags for the GSI application include(gsiapp_compiler_flags) @@ -158,6 +167,12 @@ if(USE_GSDCLOUD) endif() target_link_libraries(gsi_fortran_obj PUBLIC gsdcloud::gsdcloud) endif() +if(USE_MGBF) + if(TARGET mgbf) + add_dependencies(gsi_fortran_obj mgbf) + endif() + target_link_libraries(gsi_fortran_obj PUBLIC mgbf::mgbf) +endif() if(OpenMP_Fortran_FOUND) target_link_libraries(gsi_fortran_obj PRIVATE OpenMP::OpenMP_Fortran) endif() diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 45d88887a3..e133273662 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -161,7 +161,7 @@ module gsimod ntotensgrp,nsclgrp,naensgrp,ngvarloc,ntlevs_ens,naensloc, & r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,l_timloc_opt,& vdl_scale,vloc_varlist,& - global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers + global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers,l_mgbf_loc use hybrid_ensemble_parameters,only : l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar use rapidrefresh_cldsurf_mod, only: init_rapidrefresh_cldsurf, & dfi_radar_latent_heat_time_period,metar_impact_radius,& @@ -529,6 +529,7 @@ module gsimod ! - innov_use_model_fed=.true. : Use FED from BG to calculate innovation. ! this requires if_model_fed=.true. ! it works either an EnVar DA run or a GSI observer run. +! 02-20-2024 yokota - add MGBF-based localization ! !EOP !------------------------------------------------------------------------- @@ -1452,6 +1453,7 @@ module gsimod ! ^ ^ ^ ^ ^ ! s_ens_h = v1L1 v2L1 v3L1 v1L2 v2L2 ! Then localization lengths will be assigned as above. +! l_mgbf_loc - if true, multi-grid beta filter is used for localization instead of recursive filter ! namelist/hybrid_ensemble/l_hyb_ens,uv_hyb_ens,q_hyb_ens,aniso_a_en,generate_ens,n_ens,& l_both_fv3sar_gfs_ens,n_ens_gfs,n_ens_fv3sar,weight_ens_gfs,weight_ens_fv3sar,nlon_ens,nlat_ens,jcap_ens,& @@ -1462,7 +1464,7 @@ module gsimod i_en_perts_io,l_ens_in_diff_time,ensemble_path,ens_fast_read,sst_staticB,limqens, & nsclgrp,l_timloc_opt,ngvarloc,naensloc,r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl,& vdl_scale,vloc_varlist,& - global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers + global_spectral_filter_sd,assign_vdl_nml,parallelization_over_ensmembers,l_mgbf_loc ! rapidrefresh_cldsurf (options for cloud analysis and surface ! enhancement for RR appilcation ): diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 05b3845627..522079ae6c 100644 --- a/src/gsi/hybrid_ensemble_isotropic.F90 +++ b/src/gsi/hybrid_ensemble_isotropic.F90 @@ -49,6 +49,7 @@ module hybrid_ensemble_isotropic ! 2016-05-13 parrish - remove beta12mult ! 2018-02-15 wu - add code for fv3_regional option ! 2022-09-15 yokota - add scale/variable/time-dependent localization +! 2024-02-20 yokota - add MGBF-based localization ! ! subroutines included: ! sub init_rf_z - initialize localization recursive filter (z direction) @@ -102,6 +103,10 @@ module hybrid_ensemble_isotropic use control_vectors, only: cvars2d,cvars3d,nc2d,nc3d use string_utility, only: StrUpCase +! For MGBF + use mg_intstate + use mg_timers + implicit none ! set default to private @@ -183,6 +188,9 @@ module hybrid_ensemble_isotropic logical,parameter:: debug=.false. +! For MGBF + type (mg_intstate_type), allocatable, dimension(:) :: obj_mgbf + real(r_kind), allocatable, dimension(:,:,:) :: hwork_mgbf contains @@ -1732,6 +1740,7 @@ subroutine destroy_ensemble use hybrid_ensemble_parameters, only: l_hyb_ens,n_ens,ntlevs_ens use hybrid_ensemble_parameters, only: en_perts,ps_bar use hybrid_ensemble_parameters, only: ntotensgrp + use hybrid_ensemble_parameters, only: l_mgbf_loc implicit none integer(i_kind) istatus,n,m,ig @@ -1750,6 +1759,7 @@ subroutine destroy_ensemble enddo deallocate(ps_bar) deallocate(en_perts) + if(l_mgbf_loc) call print_mg_timers("mgbf_timing_cpu.csv", print_cpu, mype) end if return @@ -3699,9 +3709,11 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) use kinds, only: r_kind,i_kind use gridmod, only: regional use hybrid_ensemble_parameters, only: n_ens,grd_loc + use hybrid_ensemble_parameters, only: l_mgbf_loc use general_sub2grid_mod, only: general_sub2grid,general_grid2sub use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer + use constants, only: zero implicit none @@ -3711,60 +3723,133 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) type(gsi_bundle),intent(inout) :: a_en(n_ens) ! Local Variables - integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus,kk real(r_kind) hwork(grd_loc%inner_vars,grd_loc%nlat,grd_loc%nlon,grd_loc%kbegin_loc:grd_loc%kend_alloc) + real(r_kind) hwork_tmp(grd_loc%lon2,grd_loc%lat2) real(r_kind),allocatable,dimension(:):: a_en_work ipnt=1 ! Apply vertical smoother on each ensemble member + if(regional.and.l_mgbf_loc.and.ig==1) then + allocate(hwork_mgbf(obj_mgbf(1)%km_a_all,obj_mgbf(1)%nm,obj_mgbf(1)%mm)) + hwork_mgbf=zero + iadvance=1 ; iback=2 +!$omp parallel do schedule(dynamic,1) private(k,kk,ii,i,j,hwork_tmp) + do k=1,n_ens + if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + do kk=1,grd_loc%nsig + ii=(k-1)*grd_loc%nsig+kk + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + hwork_tmp(i,j)=a_en(k)%r3(ipnt)%q(j,i,kk) + enddo + enddo + do j=1,obj_mgbf(1)%mm + do i=1,obj_mgbf(1)%nm + hwork_mgbf(ii,i,j)=hwork_tmp(i+1,j+1) + enddo + enddo + enddo + enddo + if(obj_mgbf(1)%km_a_all==obj_mgbf(1)%km_all & + &.and. obj_mgbf(1)%nm==obj_mgbf(1)%im & + &.and. obj_mgbf(1)%mm==obj_mgbf(1)%jm) then + obj_mgbf(1)%VALL=zero + obj_mgbf(1)%VALL(1:obj_mgbf(1)%km_all,1:obj_mgbf(1)%im,1:obj_mgbf(1)%jm)=hwork_mgbf + elseif(obj_mgbf(1)%l_new_map) then + call obj_mgbf(1)%anal_to_filt_all2(hwork_mgbf) + else + call obj_mgbf(1)%anal_to_filt_all(hwork_mgbf) + endif + else ! To avoid my having to touch the general sub2grid and grid2sub, ! get copy for ensemble components to work array - allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) - if(istatus/=0) then - write(6,*)'bkgcov_a_en_new_factorization: trouble in alloc(a_en_work)' - call stop2(999) + allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) + if(istatus/=0) then + write(6,*)'bkgcov_a_en_new_factorization: trouble in alloc(a_en_work)' + call stop2(999) + endif + iadvance=1 ; iback=2 +!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie) + do k=1,n_ens + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + ii=(k-1)*a_en(1)%ndim + is=ii+1 + ie=ii+a_en(1)%ndim + a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) + enddo endif - iadvance=1 ; iback=2 -!$omp parallel do schedule(static,1) private(k,ii,is,ie) - do k=1,n_ens - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - ii=(k-1)*a_en(1)%ndim - is=ii+1 - ie=ii+a_en(1)%ndim - a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) - enddo - -! Convert from subdomain to full horizontal field distributed among processors - call general_sub2grid(grd_loc,a_en_work,hwork) ! Apply horizontal smoother for number of horizontal scales if(regional) then - iadvance=1 ; iback=2 - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - iadvance=2 ; iback=1 - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + if(l_mgbf_loc.and.ig==1) then + call obj_mgbf(1)%filtering_procedure(obj_mgbf(1)%mgbf_proc,0) + else +! Convert from subdomain to full horizontal field distributed among processors + call general_sub2grid(grd_loc,a_en_work,hwork) + iadvance=1 ; iback=2 + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + iadvance=2 ; iback=1 + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) +! Put back onto subdomains + call general_grid2sub(grd_loc,hwork,a_en_work) + endif else +! Convert from subdomain to full horizontal field distributed among processors + call general_sub2grid(grd_loc,a_en_work,hwork) call sf_xy(ig,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) - end if - ! Put back onto subdomains - call general_grid2sub(grd_loc,hwork,a_en_work) + call general_grid2sub(grd_loc,hwork,a_en_work) + end if ! Retrieve ensemble components from long vector ! Apply vertical smoother on each ensemble member - iadvance=2 ; iback=1 -!$omp parallel do schedule(static,1) private(k,ii,is,ie) - do k=1,n_ens - ii=(k-1)*a_en(1)%ndim - is=ii+1 - ie=ii+a_en(1)%ndim - a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - enddo - deallocate(a_en_work) + if(regional.and.l_mgbf_loc.and.ig==1) then + if(obj_mgbf(1)%km_a_all==obj_mgbf(1)%km_all & + &.and. obj_mgbf(1)%nm==obj_mgbf(1)%im & + &.and. obj_mgbf(1)%mm==obj_mgbf(1)%jm) then + hwork_mgbf=obj_mgbf(1)%VALL(1:obj_mgbf(1)%km_all,1:obj_mgbf(1)%im,1:obj_mgbf(1)%jm) + obj_mgbf(1)%VALL=zero + elseif(obj_mgbf(1)%l_new_map) then + call obj_mgbf(1)%filt_to_anal_all2(hwork_mgbf) + else + call obj_mgbf(1)%filt_to_anal_all(hwork_mgbf) + endif + iadvance=2 ; iback=1 +!$omp parallel do schedule(dynamic,1) private(k,kk,ii,i,j,hwork_tmp) + do k=1,n_ens + do kk=1,grd_loc%nsig + ii=(k-1)*grd_loc%nsig+kk + hwork_tmp=zero + do j=1,obj_mgbf(1)%mm + do i=1,obj_mgbf(1)%nm + hwork_tmp(i+1,j+1)=hwork_mgbf(ii,i,j) + enddo + enddo + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + a_en(k)%r3(ipnt)%q(j,i,kk)=hwork_tmp(i,j) + enddo + enddo + enddo + if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(hwork_mgbf) + else + iadvance=2 ; iback=1 +!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*a_en(1)%ndim + is=ii+1 + ie=ii+a_en(1)%ndim + a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(a_en_work) + endif return end subroutine bkgcov_a_en_new_factorization @@ -3797,6 +3882,7 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) use gridmod, only: regional use hybrid_ensemble_parameters, only: n_ens,grd_loc use hybrid_ensemble_parameters, only: nval_lenz_en + use hybrid_ensemble_parameters, only: l_mgbf_loc use general_sub2grid_mod, only: general_grid2sub use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -3809,8 +3895,9 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) real(r_kind),dimension(nval_lenz_en),intent(in ) :: z ! Local Variables - integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus,kk real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) + real(r_kind) hwork_tmp(grd_loc%lon2,grd_loc%lat2) !NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) ! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, ! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global @@ -3825,6 +3912,13 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) call stop2(999) endif + if(.not.regional.or..not.l_mgbf_loc) then + allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) + if(istatus/=0) then + write(6,*)'ckgcov_a_en_new_factorization: trouble in alloc(a_en_work)' + call stop2(999) + endif + endif if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then ! no work to be done on this processor, but hwork still has allocated space, since @@ -3833,46 +3927,84 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) else ! Apply horizontal smoother for number of horizontal scales if(regional) then + if(l_mgbf_loc) then + ii=0 + do k=1,obj_mgbf(ig)%km_all + do j=1-obj_mgbf(ig)%hy,obj_mgbf(ig)%jm+obj_mgbf(ig)%hy + do i=1-obj_mgbf(ig)%hx,obj_mgbf(ig)%im+obj_mgbf(ig)%hx + ii=ii+1 + obj_mgbf(ig)%VALL(k,i,j)=z(ii) + enddo + enddo + enddo + call obj_mgbf(ig)%filtering_procedure(obj_mgbf(ig)%mgbf_proc,1) + else ! Make a copy of input variable z to hwork - hwork=z - iadvance=2 ; iback=1 - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + hwork=z + iadvance=2 ; iback=1 + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) +! Put back onto subdomains + call general_grid2sub(grd_loc,hwork,a_en_work) + endif else #ifdef LATER call sqrt_sf_xy(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) #else write(6,*) ' problem with ibm compiler with "use hybrid_ensemble_isotropic, only: sqrt_sf_xy"' #endif /*LATER*/ +! Put back onto subdomains + call general_grid2sub(grd_loc,hwork,a_en_work) end if end if -! Put back onto subdomains - allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) - if(istatus/=0) then - write(6,*)'ckgcov_a_en_new_factorization: trouble in alloc(a_en_work)' - call stop2(999) - endif - call general_grid2sub(grd_loc,hwork,a_en_work) - ! Retrieve ensemble components from long vector - ii=0 - do k=1,n_ens - is=ii+1 - ie=ii+a_en(1)%ndim - a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) - ii=ii+a_en(1)%ndim - enddo - deallocate(a_en_work) - ! Apply vertical smoother on each ensemble member - iadvance=2 ; iback=1 -!$omp parallel do schedule(static,1) private(k) - do k=1,n_ens - - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - - enddo + if(regional.and.l_mgbf_loc) then + allocate(hwork_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)) + hwork_mgbf=zero + if(obj_mgbf(ig)%km_a_all==obj_mgbf(ig)%km_all & + &.and. obj_mgbf(ig)%nm==obj_mgbf(ig)%im & + &.and. obj_mgbf(ig)%mm==obj_mgbf(ig)%jm) then + hwork_mgbf=obj_mgbf(ig)%VALL(1:obj_mgbf(ig)%km_all,1:obj_mgbf(ig)%im,1:obj_mgbf(ig)%jm) + obj_mgbf(ig)%VALL=zero + elseif(obj_mgbf(ig)%l_new_map) then + call obj_mgbf(ig)%filt_to_anal_all2(hwork_mgbf) + else + call obj_mgbf(ig)%filt_to_anal_all(hwork_mgbf) + endif + iadvance=2 ; iback=1 +!$omp parallel do schedule(dynamic,1) private(k,kk,ii,i,j,hwork_tmp) + do k=1,n_ens + do kk=1,grd_loc%nsig + ii=(k-1)*grd_loc%nsig+kk + hwork_tmp=zero + do j=1,obj_mgbf(ig)%mm + do i=1,obj_mgbf(ig)%nm + hwork_tmp(i+1,j+1)=hwork_mgbf(ii,i,j) + enddo + enddo + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + a_en(k)%r3(ipnt)%q(j,i,kk)=hwork_tmp(i,j) + enddo + enddo + enddo + if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(hwork_mgbf) + else + iadvance=2 ; iback=1 +!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*a_en(1)%ndim + is=ii+1 + ie=ii+a_en(1)%ndim + a_en(k)%values(1:a_en(k)%ndim)=a_en_work(is:ie) + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(a_en_work) + endif return end subroutine ckgcov_a_en_new_factorization @@ -3910,6 +4042,7 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) use gridmod, only: regional use hybrid_ensemble_parameters, only: n_ens,grd_loc use hybrid_ensemble_parameters, only: nval_lenz_en + use hybrid_ensemble_parameters, only: l_mgbf_loc use general_sub2grid_mod, only: general_sub2grid use gsi_bundlemod, only: gsi_bundle use gsi_bundlemod, only: gsi_bundlegetpointer @@ -3922,8 +4055,9 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) real(r_kind),dimension(nval_lenz_en),intent(inout) :: z ! Local Variables - integer(i_kind) ii,k,iadvance,iback,is,ie,ipnt,istatus + integer(i_kind) ii,i,j,k,iadvance,iback,is,ie,ipnt,istatus,kk real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) + real(r_kind) hwork_tmp(grd_loc%lon2,grd_loc%lat2) !NOTE: nval_lenz_en = nhoriz*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) ! and nhoriz = grd_loc%nlat*grd_loc%nlon for regional, ! nhoriz = (sp_loc%jcap+1)*(sp_loc%jcap+2) for global @@ -3939,32 +4073,56 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) endif ! Apply vertical smoother on each ensemble member - iadvance=1 ; iback=2 -!$omp parallel do schedule(static,1) private(k) - do k=1,n_ens - - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - - enddo - + if(regional.and.l_mgbf_loc) then + allocate(hwork_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)) + hwork_mgbf=zero + iadvance=1 ; iback=2 +!$omp parallel do schedule(dynamic,1) private(k,kk,ii,i,j,hwork_tmp) + do k=1,n_ens + if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + do kk=1,grd_loc%nsig + ii=(k-1)*grd_loc%nsig+kk + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + hwork_tmp(i,j)=a_en(k)%r3(ipnt)%q(j,i,kk) + enddo + enddo + do j=1,obj_mgbf(ig)%mm + do i=1,obj_mgbf(ig)%nm + hwork_mgbf(ii,i,j)=hwork_tmp(i+1,j+1) + enddo + enddo + enddo + enddo + if(obj_mgbf(ig)%km_a_all==obj_mgbf(ig)%km_all & + &.and. obj_mgbf(ig)%nm==obj_mgbf(ig)%im & + &.and. obj_mgbf(ig)%mm==obj_mgbf(ig)%jm) then + obj_mgbf(ig)%VALL=zero + obj_mgbf(ig)%VALL(1:obj_mgbf(ig)%km_all,1:obj_mgbf(ig)%im,1:obj_mgbf(ig)%jm)=hwork_mgbf + elseif(obj_mgbf(ig)%l_new_map) then + call obj_mgbf(ig)%anal_to_filt_all2(hwork_mgbf) + else + call obj_mgbf(ig)%anal_to_filt_all(hwork_mgbf) + endif + deallocate(hwork_mgbf) + else ! To avoid my having to touch the general sub2grid and grid2sub, ! get copy for ensemble components to work array - allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) - if(istatus/=0) then - write(6,*)'ckgcov_a_en_new_factorization_ad: trouble in alloc(a_en_work)' - call stop2(999) + allocate(a_en_work(n_ens*a_en(1)%ndim),stat=istatus) + if(istatus/=0) then + write(6,*)'ckgcov_a_en_new_factorization_ad: trouble in alloc(a_en_work)' + call stop2(999) + endif + iadvance=1 ; iback=2 +!$omp parallel do schedule(dynamic,1) private(k,ii,is,ie) + do k=1,n_ens + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + ii=(k-1)*a_en(1)%ndim + is=ii+1 + ie=ii+a_en(1)%ndim + a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) + enddo endif - ii=0 - do k=1,n_ens - is=ii+1 - ie=ii+a_en(1)%ndim - a_en_work(is:ie)=a_en(k)%values(1:a_en(k)%ndim) - ii=ii+a_en(1)%ndim - enddo - -! Convert from subdomain to full horizontal field distributed among processors - call general_sub2grid(grd_loc,a_en_work,hwork) - deallocate(a_en_work) if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then ! no work to be done on this processor, but z still has allocated space, since @@ -3973,15 +4131,36 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) else ! Apply horizontal smoother for number of horizontal scales if(regional) then - iadvance=1 ; iback=2 - call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) - z=hwork + if(l_mgbf_loc) then + call obj_mgbf(ig)%filtering_procedure(obj_mgbf(ig)%mgbf_proc,-1) + ii=0 + do k=1,obj_mgbf(ig)%km_all + do j=1-obj_mgbf(ig)%hy,obj_mgbf(ig)%jm+obj_mgbf(ig)%hy + do i=1-obj_mgbf(ig)%hx,obj_mgbf(ig)%im+obj_mgbf(ig)%hx + ii=ii+1 + z(ii)=obj_mgbf(ig)%VALL(k,i,j) + enddo + enddo + enddo + else +! Convert from subdomain to full horizontal field distributed among processors + call general_sub2grid(grd_loc,a_en_work,hwork) + iadvance=1 ; iback=2 + call new_factorization_rf_x(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + call new_factorization_rf_y(hwork,iadvance,iback,grd_loc%kend_loc+1-grd_loc%kbegin_loc,ig) + z=hwork + endif else +! Convert from subdomain to full horizontal field distributed among processors + call general_sub2grid(grd_loc,a_en_work,hwork) call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) end if end if + if(.not.regional.or..not.l_mgbf_loc) then + deallocate(a_en_work) + endif + return end subroutine ckgcov_a_en_new_factorization_ad @@ -4202,6 +4381,7 @@ subroutine hybens_localization_setup use hybrid_ensemble_parameters, only: ntotensgrp,naensgrp,naensloc,ntlevs_ens,nsclgrp,assign_vdl_nml use hybrid_ensemble_parameters, only: en_perts,vdl_scale,vloc_varlist,global_spectral_filter_sd use hybrid_ensemble_parameters, only: ngvarloc + use hybrid_ensemble_parameters, only: l_mgbf_loc use gsi_io, only: verbose use string_utility, only: StrLowCase @@ -4221,6 +4401,7 @@ subroutine hybens_localization_setup real(r_kind), pointer :: values(:) => NULL() integer(i_kind) :: iscl, iv, smooth_scales_num character(len=*),parameter::myname_=myname//'*hybens_localization_setup' + character(len=40) :: mgbfname='mgbf_locXX.nml' l_read_success=.false. print_verbose=.false. .and. mype == 0 @@ -4322,30 +4503,39 @@ subroutine hybens_localization_setup call normal_new_factorization_rf_z if ( regional ) then ! convert s_ens_h from km to grid units. - if ( vvlocal ) then - allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens,naensloc)) - allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens,naensloc)) - call convert_km_to_grid_units(s_ens_h_gu_x(1:nz,:),s_ens_h_gu_y(1:nz,:),nz) - do n=2,n_ens - nk=(n-1)*nz - do k=1,nz - s_ens_h_gu_x(nk+k,:)=s_ens_h_gu_x(k,:) - s_ens_h_gu_y(nk+k,:)=s_ens_h_gu_y(k,:) - enddo + if ( l_mgbf_loc ) then + allocate(obj_mgbf(naensgrp)) + do ig=1,naensgrp + write(mgbfname(9:10),'(i2.2)') ig + call obj_mgbf(ig)%mg_initialize(trim(mgbfname)) enddo - call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl) - call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl) - else - allocate(s_ens_h_gu_x(1,naensloc)) - allocate(s_ens_h_gu_y(1,naensloc)) - call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz) - call init_rf_x(s_ens_h_gu_x,kl) - call init_rf_y(s_ens_h_gu_y,kl) endif - call normal_new_factorization_rf_x - call normal_new_factorization_rf_y - deallocate(s_ens_h_gu_x) - deallocate(s_ens_h_gu_y) + if( .not. l_mgbf_loc .or. nsclgrp > 1 ) then + if ( vvlocal ) then + allocate(s_ens_h_gu_x(grd_loc%nsig*n_ens,naensloc)) + allocate(s_ens_h_gu_y(grd_loc%nsig*n_ens,naensloc)) + call convert_km_to_grid_units(s_ens_h_gu_x(1:nz,:),s_ens_h_gu_y(1:nz,:),nz) + do n=2,n_ens + nk=(n-1)*nz + do k=1,nz + s_ens_h_gu_x(nk+k,:)=s_ens_h_gu_x(k,:) + s_ens_h_gu_y(nk+k,:)=s_ens_h_gu_y(k,:) + enddo + enddo + call init_rf_x(s_ens_h_gu_x(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl) + call init_rf_y(s_ens_h_gu_y(grd_loc%kbegin_loc:grd_loc%kend_alloc,:),kl) + else + allocate(s_ens_h_gu_x(1,naensloc)) + allocate(s_ens_h_gu_y(1,naensloc)) + call convert_km_to_grid_units(s_ens_h_gu_x,s_ens_h_gu_y,nz) + call init_rf_x(s_ens_h_gu_x,kl) + call init_rf_y(s_ens_h_gu_y,kl) + endif + call normal_new_factorization_rf_x + call normal_new_factorization_rf_y + deallocate(s_ens_h_gu_x) + deallocate(s_ens_h_gu_y) + endif else call init_sf_xy(jcap_ens) endif @@ -4533,7 +4723,13 @@ subroutine hybens_localization_setup ! but will need to rearrange so this can be set in control_vectors ! and triggered by lsqrtb. if ( regional ) then - nval_lenz_en = grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) + if ( l_mgbf_loc ) then + nval_lenz_en = maxval( obj_mgbf(1:naensgrp)%km_all & + & * (obj_mgbf(1:naensgrp)%im + obj_mgbf(1:naensgrp)%hx*2) & + & * (obj_mgbf(1:naensgrp)%jm + obj_mgbf(1:naensgrp)%hy*2) ) + else + nval_lenz_en = grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) + endif else nval_lenz_en = sp_loc%nc*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) endif diff --git a/src/gsi/hybrid_ensemble_parameters.f90 b/src/gsi/hybrid_ensemble_parameters.f90 index 23065ebb5b..d31eccb7e4 100644 --- a/src/gsi/hybrid_ensemble_parameters.f90 +++ b/src/gsi/hybrid_ensemble_parameters.f90 @@ -149,6 +149,7 @@ module hybrid_ensemble_parameters ! =0.0: cross-scale covariance is decreased to zero ! =0.5: cross-scale covariance is decreased to half ! =1.0: cross-scale covariance is retained +! l_mgbf_loc: if true, multi-grid beta filter is used for localization instead of recursive filter !===================================================================================================== ! ! @@ -183,6 +184,7 @@ module hybrid_ensemble_parameters ! 2015-02-11 Hu - add flag l_ens_in_diff_time to force GSI hybrid use ensembles not available at analysis time ! 2015-09-18 todling - add sst_staticB to control use of ensemble SST error covariance ! 2022-09-15 yokota - add scale/variable/time-dependent localization +! 2024-02-20 yokota - add MGBF-based localization ! ! subroutines included: @@ -333,6 +335,7 @@ module hybrid_ensemble_parameters public :: alphacvarsclgrpmat public :: l_timloc_opt public :: r_ensloccov4tim,r_ensloccov4var,r_ensloccov4scl + public :: l_mgbf_loc public :: idaen3d,idaen2d public :: ens_fast_read public :: parallelization_over_ensmembers @@ -348,6 +351,7 @@ module hybrid_ensemble_parameters logical l_hyb_ens,uv_hyb_ens,q_hyb_ens,oz_univ_static,sst_staticB logical l_timloc_opt + logical l_mgbf_loc logical aniso_a_en logical full_ensemble,pwgtflg logical generate_ens @@ -462,6 +466,7 @@ subroutine init_hybrid_ensemble_parameters l_hyb_ens=.false. l_timloc_opt=.false. + l_mgbf_loc=.false. full_ensemble=.false. pwgtflg=.false. uv_hyb_ens=.false. diff --git a/src/mgbf/CMakeLists.txt b/src/mgbf/CMakeLists.txt new file mode 100644 index 0000000000..9ee36c8329 --- /dev/null +++ b/src/mgbf/CMakeLists.txt @@ -0,0 +1,98 @@ +cmake_minimum_required(VERSION 3.15) + +project(mgbf + VERSION 1.0.0 + LANGUAGES Fortran) + +list(APPEND CMAKE_MODULE_PATH "${CMAKE_CURRENT_SOURCE_DIR}/cmake") +set(CMAKE_DIRECTORY_LABELS ${PROJECT_NAME}) + +include(GNUInstallDirs) + +if(NOT CMAKE_BUILD_TYPE MATCHES "^(Debug|Release|RelWithDebInfo|MinSizeRel)$") + message(STATUS "Setting build type to 'Release' as none was specified.") + set(CMAKE_BUILD_TYPE + "Release" + CACHE STRING "Choose the type of build." FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") +endif() + +if(NOT CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU|Intel)$") + message(WARNING "${CMAKE_Fortran_COMPILER_ID} is not supported.") +endif() + +if(CMAKE_Fortran_COMPILER_ID MATCHES "^(Intel)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g -traceback -convert big_endian") +elseif(CMAKE_Fortran_COMPILER_ID MATCHES "^(GNU)$") + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -g -fbacktrace -fconvert=big-endian") +endif() + +if(NOT CMAKE_BUILD_TYPE MATCHES "Debug") + add_definitions(-DNDEBUG) +endif() + +list(APPEND MGBF_SRC +kinds.f90 +jp_pkind.f90 +jp_pkind2.f90 +jp_pietc.f90 +jp_pietc_s.f90 +jp_pmat.f90 +jp_pmat4.f90 +jp_pbfil.f90 +jp_pbfil2.f90 +jp_pbfil3.f90 +mg_mppstuff.f90 +mg_domain.f90 +mg_domain_loc.f90 +mg_parameter.f90 +mg_bocos.f90 +mg_transfer.f90 +mg_generations.f90 +mg_interpolate.f90 +mg_filtering.f90 +mg_timers.f90 +mg_entrymod.f90 +mg_intstate.f90 +mg_input.f90 +) + +set(module_dir "${CMAKE_CURRENT_BINARY_DIR}/include/mgbf") +add_library(mgbf STATIC ${MGBF_SRC}) +add_library(${PROJECT_NAME}::mgbf ALIAS mgbf) +set_target_properties(mgbf PROPERTIES Fortran_MODULE_DIRECTORY "${module_dir}") +target_include_directories(mgbf PUBLIC $ + $) + +install(DIRECTORY ${module_dir} DESTINATION ${CMAKE_INSTALL_PREFIX}/include) + +install(TARGETS mgbf + EXPORT ${PROJECT_NAME}Exports + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR} + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR}) + +# Package config +include(CMakePackageConfigHelpers) +set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}) + +export(EXPORT ${PROJECT_NAME}Exports + NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME}-targets.cmake) + +configure_package_config_file( + ${CMAKE_CURRENT_SOURCE_DIR}/cmake/PackageConfig.cmake.in ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config.cmake + INSTALL_DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(FILES ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +write_basic_package_version_file( + ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY AnyNewerVersion) +install(FILES ${CMAKE_BINARY_DIR}/${PROJECT_NAME}-config-version.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +install(EXPORT ${PROJECT_NAME}Exports + NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME}-targets.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) diff --git a/src/mgbf/cmake/PackageConfig.cmake.in b/src/mgbf/cmake/PackageConfig.cmake.in new file mode 100644 index 0000000000..e64cb4ef87 --- /dev/null +++ b/src/mgbf/cmake/PackageConfig.cmake.in @@ -0,0 +1,19 @@ +@PACKAGE_INIT@ + +#@PROJECT_NAME@-config.cmake +# +# Imported interface targets provided: +# * @PROJECT_NAME@::MGBF - MGBF library target + +# Include targets file. This will create IMPORTED target @PROJECT_NAME@ +include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-targets.cmake") +include("${CMAKE_CURRENT_LIST_DIR}/@PROJECT_NAME@-config-version.cmake") +include(CMakeFindDependencyMacro) + +# Get the build type from library target +get_target_property(@PROJECT_NAME@_BUILD_TYPES @PROJECT_NAME@::@PROJECT_NAME@ IMPORTED_CONFIGURATIONS) + +check_required_components("@PROJECT_NAME@") + +get_target_property(location @PROJECT_NAME@::@PROJECT_NAME@ LOCATION) +message(STATUS "Found @PROJECT_NAME@: ${location} (found version \"${PACKAGE_VERSION}\")") diff --git a/src/mgbf/jp_pbfil.f90 b/src/mgbf/jp_pbfil.f90 new file mode 100644 index 0000000000..89a9196596 --- /dev/null +++ b/src/mgbf/jp_pbfil.f90 @@ -0,0 +1,1119 @@ +submodule(mg_parameter) jp_pbfil +!$$$ submodule documentation block +! . . . . +! module: jp_pbfil +! prgmmr: purser org: NOAA/EMC date: 2019-03 +! +! abstract: Codes for the beta filters +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! cholaspect1 - +! cholaspect2 - +! cholaspect3 - +! cholaspect4 - +! getlinesum1 - +! getlinesum2 - +! getlinesum3 - +! getlinesum4 - +! rbeta1 - +! rbeta2 - +! rbeta3 - +! rbeta4 - +! vrbeta4 - +! rbeta1T - +! rbeta2T - +! rbeta3T - +! rbeta4T - +! vrbeta4t - +! vrbeta1 - +! vrbeta2 - +! vrbeta3 - +! vrbeta1T - +! vrbeta2T - +! vrbeta3T - +! +! Functions Included: +! +! remarks: +! The filters invoke the aspect tensor information encoded by the +! Cholesky lower-triangular factors, el, of the INVERSE aspect tensors. +! The routines, "cholaspect", convert (in place) the field of given +! aspect tensors A to the equivalent cholesky factors of A^(-1). +! The routines, "getlinesum" precompute the normalization coefficients +! for each line (row) of the implied matrix form of the beta filter +! so that the normalized line sum associated with each point of +! application becomes unity. +! This makes the application of each filter significantly faster +! than having to work out the normalization on the fly. +! Be sure to have run cholaspect, and then getlinesum, prior to applying +! the beta filters themselves. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use kinds, only: dp=>r_kind +use jp_pietc, only: u1 +implicit none + +contains + +!============================================================================= +module subroutine cholaspect1(lx,mx, el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx +real(dp),dimension(1,1,lx:mx),intent(inout):: el +!----------------------------------------------------------------------------- +integer :: ix +!============================================================================= +do ix=lx,mx; el(1,1,ix)=u1/sqrt(el(1,1,ix)); enddo +end subroutine cholaspect1 +!============================================================================= +module subroutine cholaspect2(lx,mx, ly,my, el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx, ly,my +real(dp),dimension(2,2,lx:mx,ly:my),intent(inout):: el +!----------------------------------------------------------------------------- +real(dp),dimension(2,2):: tel +integer :: ix,iy +!============================================================================= +do iy=ly,my; do ix=lx,mx + tel=el(:,:,ix,iy); call inv(tel); call l1lm(tel,el(:,:,ix,iy)) +enddo; enddo +end subroutine cholaspect2 +!============================================================================= +module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx, ly,my, lz,mz +real(dp),dimension(3,3,lx:mx,ly:my,lz:mz),intent(inout):: el +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: tel +integer :: ix,iy,iz +!============================================================================= +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + tel=el(:,:,ix,iy,iz); call inv(tel); call l1lm(tel,el(:,:,ix,iy,iz)) +enddo; enddo; enddo +end subroutine cholaspect3 +!============================================================================= +module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) ! [cholaspect] +!============================================================================= +! Convert the given field, el, of aspect tensors into the equivalent +! field +! of Cholesky lower-triangular factors of the inverses of the aspect +! tensors. +!============================================================================= +use jp_pmat, only: inv, l1lm +integer, intent(in ):: lx,mx, ly,my, lz,mz, lw,mw +real(dp),dimension(4,4,lx:mx,ly:my,lz:mz,lw:mw),& + intent(inout):: el +!----------------------------------------------------------------------------- +real(dp),dimension(4,4):: tel +integer :: ix,iy,iz,iw +!============================================================================= +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + tel=el(:,:,ix,iy,iz,iw); call inv(tel); call l1lm(tel,el(:,:,ix,iy,iz,iw)) +enddo; enddo; enddo; enddo +end subroutine cholaspect4 + +!============================================================================= +module subroutine getlinesum1(this,hx,lx,mx, el, ss) ! [getlinesum] +!============================================================================= +! Get inverse of the line-sum of the matrix representing the +! unnormalized +! beta function with aspect tensor pasp=(el*el^T)^(-1), and invert the +! result +! so it can be used subsequently in the normalized version of this +! filter. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx +real(dp),dimension(1,1,Lx:Mx),intent(in ):: el +real(dp),dimension(lx:mx),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter:: eps=1.e-12 +real(dp) :: s,rr,rrc,exx,x +integer :: ix,gxl,gxm,gx +!============================================================================= +do ix=Lx,Mx + s=0 + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + gxl=ceiling(-x+eps); gxm=floor( x-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum1; filter reach fx becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=(x*exx)**2; rrc=u1-rr + s=s+rrc**this%p + enddo + ss(ix)=u1/s +enddo +end subroutine getlinesum1 +!============================================================================= +module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) ! [getlinesum] +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my +real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el +real(dp),dimension( lx:mx,ly:my),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(2,2):: tel +real(dp) :: s,rr,rrx,rrc,exx,eyy,eyx,x,y,xc +integer :: ix,gx,gxl,gxm +integer :: iy,gy,gyl,gym +!============================================================================= +do iy=Ly,My; do ix=Lx,Mx + s=0 + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + gyl=ceiling(-y+eps); gym=floor( y-eps) + if(gyl<-hy.or.gym>hy)& + stop 'In getlinesum2; filter reach becomes too large for hy' + do gy=gyl,gym + y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x=sqrt(u1-rrx) + gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum2; filter reach becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + s=s+rrc**this%p + enddo! gx + enddo! gy + ss(ix,iy)=u1/s +enddo; enddo! ix, iy +end subroutine getlinesum2 +!============================================================================= +module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss) ! [getlinesum] +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my, & + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el +real(dp),dimension( lx:mx,ly:my,lz:mz),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(3,3):: tel +real(dp) :: s,rr,rrx,rry,rrc,& + exx,eyy,ezz,eyx,ezx,ezy, x,y,z,xc,yc +integer :: ix,gx,gxl,gxm +integer :: iy,gy,gyl,gym +integer :: iz,gz,gzl,gzm +!============================================================================= +ss=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + s=0 + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1) + ezy=tel(3,2) + z=u1/ezz + gzl=ceiling(-z+eps); gzm=floor( z-eps) + if(gzl<-hz.or.gzm>hz)& + stop 'In getlinesum3; filter reach becomes too large for hz' + do gz=gzl,gzm + z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + gyl=ceiling((yc-y)/eyy+eps); gym=floor((yc+y)/eyy-eps) + if(gyl<-hy.or.gym>hy)& + stop 'In getlinesum3; filter reach becomes too large for hy' + do gy=gyl,gym + y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum3; filter reach becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + s=s+rrc**this%p + enddo! gx + enddo! gy + enddo! gz + ss(ix,iy,iz)=u1/s +enddo; enddo; enddo! ix, iy, iz +end subroutine getlinesum3 +!============================================================================= +module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el, ss) ! [getlinesum] +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my, & + hz,lz,mz, & + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( lx:mx,ly:my,lz:mz,Lw:Mw),intent( out):: ss +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(4,4):: tel +real(dp) :: s,rr,rrx,rry,rrz,rrc, & + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz, x,y,z,w,& + xc,yc,zc +integer :: ix,gx,gxl,gxm +integer :: iy,gy,gyl,gym +integer :: iz,gz,gzl,gzm +integer :: iw,gw,gwl,gwm +!============================================================================= +ss=0 +do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + s=0 + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + w=u1/eww + gwl=ceiling(-w+eps); gwm=floor( w-eps) + if(gwl<-hw.or.gwm>hw)& + stop 'In getlinesum4; filter reach becomes too large for hw' + do gw=gwl,gwm + w=gw; zc=-w*ewz + rrz=(w-eww)**2; z =sqrt(u1-rrz) + gzl=ceiling((zc-z)/ezz+eps); gzm=floor((zc+z)/ezz-eps) + if(gzl<-hz.or.gzm>hz)& + stop 'In getlinesum4; filter reach becomes too large for hz' + do gz=gzl,gzm + z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + gyl=ceiling((yc-y)/eyy+eps); gym=floor((yc+y)/eyy-eps) + if(gyl<-hy.or.gym>hy)& + stop 'In getlinesum4; filter reach becomes too large for hy' + do gy=gyl,gym + y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + gxl=ceiling((xc-x)/exx+eps); gxm=floor((xc+x)/exx-eps) + if(gxl<-hx.or.gxm>hx)& + stop 'In getlinesum4; filter reach becomes too large for hx' + do gx=gxl,gxm + x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + s=s+rrc**this%p + enddo! gx + enddo! gy + enddo! gz + enddo! gw + ss(ix,iy,iz,iw)=u1/s +enddo; enddo; enddo; enddo! ix, iy, iz, iw +end subroutine getlinesum4 + +!============================================================================= +module subroutine rbeta1(this,hx,lx,mx, el,ss, a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 1D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx. +! The output data occupy the central region +! Lx <= ix <= Mx. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx +real(dp),dimension( Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx):: b +real(dp) :: x,tb,s,rr,rrc,frow,exx +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + tb=0; s=ss(ix) + exx=el(ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx) + enddo + b(ix)=tb +enddo +a=b +end subroutine rbeta1 +!============================================================================= +module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 2D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy +! The output data occupy the central region +! Lx <= ix <= Mx, Ly <= iy <= My. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my +real(dp),dimension(2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(2,2) :: tel +real(dp) :: tb,s,rr,rrx,rrc,& + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx,jy) + enddo! gx + enddo! gy + b(ix,iy)=tb +enddo; enddo! ix, iy +a=b +end subroutine rbeta2 +!============================================================================= +module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 3D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy, Lz-hz <= Jz <= mz+hz +! The output data occupy the central region +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b +real(dp),dimension(3,3) :: tel +real(dp):: s,tb,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx,jy,jz) + enddo! gx + enddo! gy + enddo! gz + b(ix,iy,iz)=tb +enddo; enddo; enddo! ix, iy, iz +a=b +end subroutine rbeta3 +!============================================================================= +module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) ! [rbeta] +!============================================================================= +! Perform a radial beta-function filter in 4D. +! It averages the surrounding density values, and so preserves the value +! (in its target region) when presented with a constant-density input +! field. +! The input data occupy the extended region: +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy, Lz-hz <= Jz <= mz+hz, +! Lw-hw <= Jw <= mw+hw +! The output data occupy the central region +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy, & + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(4,4) :: tel +real(dp):: s,tb,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=lw,mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + w=u1/eww + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(jx,jy,jz,jw) + enddo! gx + enddo! gy + enddo! gz + enddo! gw + b(ix,iy,iz,iw)=tb +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine rbeta4 + +!============================================================================= +! Vector versions of the above routines: +!============================================================================= +module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el,ss,a) ! [rbeta] +!============================================================================= +! Vector version of rbeta4 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy, & + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(nv) :: tb +real(dp),dimension(4,4) :: tel +real(dp):: s,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww, eyx,ezx,ewx, ezy,ewy, ewz,& + x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=lw,mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + w=u1/eww + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx,jy,jz,jw) + enddo! gx + enddo! gy + enddo! gz + enddo! gw + b(:,ix,iy,iz,iw)=tb +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine vrbeta4 + +!============================================================================= +module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 1D. +! It conserves "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= mx+hx. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx +real(dp),dimension(1,1,Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx):: b +real(dp) :: ta,s,rr,rrc,frow,exx,x +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + ta=a(ix); s=ss(ix) + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx)=b(jx)+frow*ta + enddo +enddo +a=b +end subroutine rbeta1t +!============================================================================= +module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 2D. +! It conserved "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx, Ly <= iy <= My. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= mx+hx, Ly-hy <= Jy <= my+hy +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx, & + hy,ly,my +real(dp),dimension(2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(2,2) :: tel +real(dp) :: ta,s,rr,rrx,rrc, & + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + ta=a(ix,iy); s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! sThis el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx,jy)=b(jx,jy)+frow*ta + enddo! gx + enddo! gy +enddo; enddo! ix, iy +a=b +end subroutine rbeta2t +!============================================================================= +module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 3D. +! It conserves "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b +real(dp),dimension(3,3) :: tel +real(dp):: ta,s,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(ix,iy,iz); s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx,jy,jz)=b(jx,jy,jz)+frow*ta + enddo! gx + enddo! gy + enddo ! gz +enddo; enddo; enddo ! ix, iy, iz +a=b +end subroutine rbeta3t +!============================================================================= +module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, & + el,ss, a) ! [rbetat] +!============================================================================= +! Perform an ADJOINT radial beta-function filter in 4D. +! It conserves "masses" initially distributed only at the closure of +! the central domain, +! Lx <= ix <= Mx, Ly <= iy <= My, Lz <= iz <= Mz, Lw <= iw <= Mw. +! The output field of the redistributed masses occupies the +! the extended domain, +! Lx-hx <= jx <= Mx+hx, Ly-hy <= Jy <= My+hy, Lz-hz <= Jz <= Mz+hz, +! Lw-hw <= Jw <= Mw+hw. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(4,4) :: tel +real(dp):: ta,s,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(ix,iy,iz,iw); s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + z=u1/ezz + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(jx,jy,jz,jw)=b(jx,jy,jz,jw)+frow*ta + enddo! gx + enddo! gy + enddo! gz + enddo! gw +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine rbeta4t + + +!============================================================================= +module subroutine vrbeta4t(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, & + hw,lw,mw, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta4t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz,& + hw,lw,mw +real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw), intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz,lw-hw:mw+hw) :: b +real(dp),dimension(nv) :: ta +real(dp),dimension(4,4) :: tel +real(dp):: s,rr,rrx,rry,rrz,rrc,frow,& + exx,eyy,ezz,eww,eyx,ezx,ewx,ezy,ewy,ewz,x,y,z,w,xc,yc,zc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +integer :: iw,jw,gw +!============================================================================= +b=0 +do iw=Lw,Mw; do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(:,ix,iy,iz,iw); s=ss(ix,iy,iz,iw) + tel=el(:,:,ix,iy,iz,iw)*this%rmom2_4 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3); eww=tel(4,4) + eyx=tel(2,1); ezx=tel(3,1); ewx=tel(4,1) + ezy=tel(3,2); ewy=tel(4,2) + ewz=tel(4,3) + z=u1/ezz + do gw=ceiling(-w+eps),floor( w-eps) + jw=iw+gw; w=gw; zc=-w*ewz + rrz=(w*eww)**2; z =sqrt(u1-rrz) + do gz=ceiling((zc-z)/ezz+eps),floor((zc+z)/ezz-eps) + jz=iz+gz; z=gz; yc=-z*ezy-w*ewy + rry=rrz+(z*ezz-zc)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx-w*ewx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx,jy,jz,jw)=b(:,jx,jy,jz,jw)+frow*ta + enddo! gx + enddo! gy + enddo! gz + enddo! gw +enddo; enddo; enddo; enddo! ix, iy, iz, iw +a=b +end subroutine vrbeta4t + +! Vector versions of the above routines: +!============================================================================= +module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) ! [rbeta] +!============================================================================= +! Vector version of rbeta1 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv,hx,Lx,mx +real(dp),dimension(1,1, Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx):: b +real(dp),dimension(nv) :: tb +real(dp) :: x,s,rr,rrc,frow,exx +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + tb=0; s=ss(ix) + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx) + enddo + b(:,ix)=tb +enddo +a=b +end subroutine vrbeta1 + +!============================================================================= +module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbeta] +!============================================================================= +! Vector version of rbeta2 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx, & + hy,ly,my +real(dp),dimension( 2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(nv) :: tb +real(dp),dimension(2,2) :: tel +real(dp) :: s,rr,rrx,rrc,& + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx,jy) + enddo! gx + enddo! gy + b(:,ix,iy)=tb +enddo; enddo! ix, iy +a=b +end subroutine vrbeta2 + +!============================================================================= +module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) ! [rbeta] +!============================================================================= +! Vector version of rbeta3 filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz):: b +real(dp),dimension(nv) :: tb +real(dp),dimension(3,3) :: tel +real(dp):: s,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + tb=0; s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + tb=tb+frow*a(:,jx,jy,jz) + enddo! gx + enddo! gy + enddo! gz + b(:,ix,iy,iz)=tb +enddo; enddo; enddo! ix, iy, iz +a=b +end subroutine vrbeta3 + +! Vector versions of the above routines: +!============================================================================= +module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta1t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv,hx,Lx,mx +real(dp),dimension(1,1,Lx:Mx), intent(in ):: el +real(dp),dimension( Lx:Mx), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx):: b +real(dp),dimension(nv) :: ta +real(dp) :: s,rr,rrc,frow,exx,x +integer :: ix,jx,gx +!============================================================================= +b=0 +do ix=Lx,Mx + ta=a(:,ix); s=ss(ix) + exx=el(1,1,ix)*this%rmom2_1 + x=u1/exx + do gx=ceiling(-x+eps),floor( x-eps) + jx=ix+gx; x=gx + rr=(x*exx)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx)=b(:,jx)+frow*ta + enddo +enddo +a=b +end subroutine vrbeta1t +!============================================================================= +module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta2t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx, & + hy,ly,my +real(dp),dimension( 2,2,Lx:Mx,Ly:My), intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My), intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy):: b +real(dp),dimension(nv) :: ta +real(dp),dimension(2,2) :: tel +real(dp) :: s,rr,rrx,rrc, & + frow,exx,eyy,eyx,x,y,xc +integer :: ix,jx,gx +integer :: iy,jy,gy +!============================================================================= +b=0 +do iy=Ly,My; do ix=Lx,Mx + ta=a(:,ix,iy); s=ss(ix,iy) + tel=el(:,:,ix,iy)*this%rmom2_2 ! This el, rescaled + exx=tel(1,1); eyy=tel(2,2) + eyx=tel(2,1) + y=u1/eyy + do gy=ceiling(-y+eps),floor( y-eps) + jy=iy+gy; y=gy; xc=-y*eyx + rrx=(y*eyy)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx,jy)=b(:,jx,jy)+frow*ta + enddo! gx + enddo! gy +enddo; enddo ! ix, iy +a=b +end subroutine vrbeta2t + +!============================================================================= +module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) ! [rbetat] +!============================================================================= +! Vector version of rbeta3t filtering nv fields at once. +!============================================================================= +class(mg_parameter_type)::this +integer, intent(in ):: nv, & + hx,Lx,mx,& + hy,ly,my,& + hz,lz,mz +real(dp),dimension( 3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el +real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz),intent(inout):: a +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-12 +real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,& + lz-hz:mz+hz):: b +real(dp),dimension(nv) :: ta +real(dp),dimension(3,3) :: tel +real(dp):: s,rr,rrx,rry,rrc,frow,& + exx,eyy,ezz,eyx,ezx,ezy,x,y,z,xc,yc +integer :: ix,jx,gx +integer :: iy,jy,gy +integer :: iz,jz,gz +!============================================================================= +b=0 +do iz=Lz,Mz; do iy=Ly,My; do ix=Lx,Mx + ta=a(:,ix,iy,iz); s=ss(ix,iy,iz) + tel=el(:,:,ix,iy,iz)*this%rmom2_3 + exx=tel(1,1); eyy=tel(2,2); ezz=tel(3,3) + eyx=tel(2,1); ezx=tel(3,1); ezy=tel(3,2) + z=u1/ezz + do gz=ceiling(-z+eps),floor( z-eps) + jz=iz+gz; z=gz; yc=-z*ezy + rry=(z*ezz)**2; y =sqrt(u1-rry) + do gy=ceiling((yc-y)/eyy+eps),floor((yc+y)/eyy-eps) + jy=iy+gy; y=gy; xc=-y*eyx-z*ezx + rrx=rry+(y*eyy-yc)**2; x =sqrt(u1-rrx) + do gx=ceiling((xc-x)/exx+eps),floor((xc+x)/exx-eps) + jx=ix+gx; x=gx + rr=rrx+(x*exx-xc)**2; rrc=u1-rr + frow=s*rrc**this%p + b(:,jx,jy,jz)=b(:,jx,jy,jz)+frow*ta + enddo! gx + enddo! gy + enddo! gz +enddo; enddo; enddo! ix, iy, iz +a=b +end subroutine vrbeta3t + +end submodule jp_pbfil + diff --git a/src/mgbf/jp_pbfil2.f90 b/src/mgbf/jp_pbfil2.f90 new file mode 100644 index 0000000000..63493f9727 --- /dev/null +++ b/src/mgbf/jp_pbfil2.f90 @@ -0,0 +1,1173 @@ +module jp_pbfil2 +!$$$ module documentation block +! . . . . +! module: jp_pbfil2 +! prgmmr: purser org: NOAA/EMC date: 2019-08 +! +! abstract: Module of data defining the exact transition rules +! of the decad algorithm based on the PG(3,2) reference +! geometry +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! An overview of this topic is given NOAA/NCEP Office Note 500. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: spi,dp +implicit none +public +private :: X, A, B +integer(spi),parameter :: X=99,A=10,B=11 +!---- Items that relate to beta line filters generally: +real(dp),allocatable,dimension(:) :: bnorm,bsprds +integer(spi) :: p,nh +!---- Items that relate only to 4D "decad" line filters: +integer(spi),dimension(4,0:9) :: dec0,dodec0t +integer(spi),dimension(4,0:11) :: dodec0 +integer(spi),dimension(0:14,0:14) :: typ +integer(spi),dimension(0:3,0:3,0:9,0:11) :: umat10 +integer(spi),dimension(0:3,0:3,0:3,12:59):: umat12 +integer(spi),dimension(0:3,0:3,4:9) :: umats +integer(spi),dimension(0:9,0:59) :: nei +integer(spi),dimension(0:9,0:11) :: dcol10 +integer(spi),dimension(0:3,12:59) :: dcol12 +integer(spi),dimension(2, 0:3) :: nei0a,jcora +integer(spi),dimension(2,1:2,4:9) :: nei0b,jcorb +integer(spi),dimension(2) :: nei17,nei22,nei33,nei38 +integer(spi),dimension(4,4,0:12) :: tcors +integer(spi),dimension(0:2,0:3) :: kcor10a5 +integer(spi),dimension(0:2,4:9) :: kcor10b1,kcor10b2 +integer(spi),dimension(12:59) :: kcor12b0 +integer(spi),dimension(0:2) :: kcor17c0,kcor22c0,kcor33c0,kcor38c0, & + kcor44c0,kcor51c0,kcor53c0,kcor58c0 +integer(spi),dimension(0:9,0:2) :: twt10a5,twt10b1,twt10b2,twt12c0 +integer(spi),dimension(0:9,0:9) :: qwt10a,qwt10b,qwt10c,qwt10d,qwt10e, & + qwt12a,qwt12b +integer(spi),dimension(0:9,0:2) :: qwt12b0 +integer(spi),dimension(0:9,0:12) :: tperms +integer(spi),dimension(0:9,0:9,0:11) :: perm10 +integer(spi),dimension(0:9,0:3,12:59) :: perm12 +integer(spi),dimension(0:9,4:9) :: perms +data p/0/ +data nh/0/ +data dec0/1,0,0,0, 0,1, 0,0, 0, 0,1, 0, 0,0,0,1, -1,-1,-1,-1, & + 1,0,1,1, -1,0,-1,0, 0,-1,0,-1, 1,1,0,1, -1, 0, 0,-1/ +data dodec0t/ & + +2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, & + -1,-1,-1,-1, 1, 1,-1,-1, 1,-1, 1,-1, & + -1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1 / +data dodec0/ & + +2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, 0, 0, 0, 0, 2, & + -1,-1,-1,-1, 1, 1,-1,-1, 1,-1, 1,-1, 1,-1,-1, 1, & + -1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, -1,-1,-1, 1/ +data typ/ X,6,8,X,X,X,X,7,3,9,5,1,0,2,4, &! 3;1;1;1;9 + X,3,6,9,8,5,X,1,X,0,X,2,X,4,7, &! 6;2;2;2;3 + X,X,3,0,6,X,9,2,8,X,5,4,X,7,1, &! 1;4;4;3;3 + X,8,X,X,3,5,0,4,6,X,X,7,9,1,2, &! 2;1;6;1;5 +!--------- + X,X,X,8,6,4,X,X,7,3,9,2,1,0,5, &! 1;1;4;1;8 + X,7,X,3,X,9,8,2,6,1,4,0,X,5,X, &! 2;2;8;2;1 + X,6,7,1,X,4,3,0,X,X,9,5,8,X,2, &! 4;4;1;4;2 + X,X,6,X,7,9,1,5,X,8,4,X,3,2,0, &! 1;2;5;3;4 +!--------- + 9,X,0,5,X,4,X,7,3,X,X,1,8,6,2, &! 3;2;3;1;6 + 9,3,X,X,0,X,5,1,X,8,4,6,X,2,7, &! 1;2;3;4;5 +!--------- + X,1,5,9,6,4,2,X,7,8,3,X,0,X,X, &! 4;2;1;1;7 +!--------- + X,7,0,X,9,8,X,4,1,X,3,5,X,2,6, &! 3;3;3;3;3 +!+++++++++ + X,1,X,4,2,3,5,B,X,A,0,9,8,7,6, &! 2;6;7 + X,X,1,A,X,0,4,9,2,8,3,7,5,6,B, &! 1;3;11 +!--------- + X,0,3,B,2,X,4,7,1,5,X,8,9,6,A/ ! 5;5;5 +data umat10/& +!---------------- 0 + 1, 1, 1, 1, 0, 1,-1, 1, 0, 0, 0, 1, -1, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-2, 0,-1, 0,-1, 0, 0, 0, 1, & + 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, & + 1, 1, 1, 1, 1, 0, 0, 0, 1,-1, 1, 0, -1, 0, 0,-1, & + 1, 0, 0, 1, 0,-1, 0,-1, 1, 0, 1, 0, 0, 1,-1, 0, & + 1, 1, 0, 1, 0,-1,-1, 0, 0, 0, 0, 1, 1, 0, 1, 0, & + 1, 1, 0, 1, 0,-1,-1,-1, -1, 0,-1,-1, 0, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, & + 1, 0, 1, 1, -1, 0, 0, 0, 0, 1, 0, 1, 0,-1,-1, 0, & + 0, 1, 0, 1, -1, 0,-1,-1, 1, 1, 0, 0, 0, 0, 1, 0, & +!---------------- 1 + 1, 1, 1, 1, 0, 1,-1, 1, 0, 0, 0, 1, -1, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-2, 0,-1, 0,-1, 0, 0, 0, 1, & + 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, & + 1, 1, 1, 1, -1, 1,-1, 0, -1, 0, 0, 0, 1, 0, 0, 1, & + 1, 0, 0, 1, -1, 0,-1, 0, 0, 1, 0, 1, 0,-1, 1, 0, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, & + 1, 0, 1, 1, 0,-1, 0,-1, 1, 0, 0, 0, 0, 1, 1, 0, & + 0, 1, 0, 1, -1,-1, 0, 0, 1, 0, 1, 1, 0, 0,-1, 0, & +!---------------- 2 + 1, 1, 1, 1, 0, 0, 0,-1, 0,-1, 1,-1, 1, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 1, 2, 1, 1, 2, 0, 0, 0,-1, & + 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, -2, 0,-1,-1, & + 1, 1, 1, 1, -1, 1,-1, 0, -1, 0, 0, 0, 1, 0, 0, 1, & + 1, 0, 0, 1, -1, 0,-1, 0, 0, 1, 0, 1, 0,-1, 1, 0, & + 1, 1, 0, 1, 0,-1,-1, 0, 0, 0, 0, 1, 1, 0, 1, 0, & + 1, 1, 0, 1, 1, 0, 1, 1, 0, 1, 1, 1, 0, 0, 0,-1, & + 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, & + 1, 0, 1, 1, 0,-1, 0,-1, 1, 0, 0, 0, 0, 1, 1, 0, & + 0, 1, 0, 1, -1,-1, 0, 0, 1, 0, 1, 1, 0, 0,-1, 0, & + !---------------- 3 + 1, 1, 1, 1, 0, 0, 0,-1, 0,-1, 1,-1, 1, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 1, 2, 1, 1, 2, 0, 0, 0,-1, & + 0, 0, 0, 1, 1, 1, 0, 1, 1, 1, 1, 1, -2, 0,-1,-1, & + 1, 1, 1, 1, 1, 0, 0, 0, 1,-1, 1, 0, -1, 0, 0,-1, & + 1, 0, 0, 1, 0,-1, 0,-1, 1, 0, 1, 0, 0, 1,-1, 0, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 1, 0, 1, 0,-1,-1,-1, -1, 0,-1,-1, 0, 0, 0, 1, & + 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, & + 1, 0, 1, 1, -1, 0, 0, 0, 0, 1, 0, 1, 0,-1,-1, 0, & + 0, 1, 0, 1, -1, 0,-1,-1, 1, 1, 0, 0, 0, 0, 1, 0, & +!---------------- 4 + 1, 0, 1, 1, 0,-1, 0,-1, -1,-1, 0,-1, 0, 0,-1, 1, & + 1, 0, 1, 0, -1,-1,-1,-2, -1, 0, 0,-1, 1, 1, 0, 1, & + 0, 0, 0, 1, 2, 0, 1, 1, 1, 1, 0, 1, -1,-1,-1,-1, & + 0, 0, 1, 0, 0, 1, 0, 0, -2, 0,-1,-1, 0,-1, 0,-1, & + 0, 0, 0, 1, 0, 0, 1, 0, 1,-1, 1, 0, 1, 1, 0, 1, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 0, 0, 1, 0,-1, 0,-1, 0, 0,-1,-1, 1, 1, 1, 1, & + 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, -1,-1,-1,-1, & + 1, 0, 1, 0, 0,-1,-1,-1, 0,-1, 0, 0, -1, 0, 0,-1, & + 0, 1, 0, 1, 0, 0,-1, 0, 1, 1, 0, 0, 1, 0, 1, 1, & +!---------------- 5 + 1, 0, 1, 1, 0,-1, 0,-1, -1,-1, 0,-1, 0, 0,-1, 1, & + 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, -1,-1,-1,-2, & + 0, 0, 0, 1, -1,-1,-1,-1, -1,-1, 0,-1, 2, 0, 1, 1, & + 0, 0, 1, 0, 0, 1, 0, 0, -2, 0,-1,-1, 0,-1, 0,-1, & + 0, 0, 0, 1, -1, 1,-1, 0, 0, 0,-1, 0, -1,-1, 0,-1, & + 1, 1, 0, 1, 1, 0, 1, 0, 0, 0, 0,-1, 0,-1,-1, 0, & + 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, -1,-1,-1,-1, & + 1, 0, 0, 1, 1, 1, 0, 0, 1, 0, 1, 0, -1,-1,-1,-1, & + 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, & + 0, 1, 0, 1, -1,-1, 0, 0, 0, 0, 1, 0, -1, 0,-1,-1, & +!---------------- 6 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 0, 0, 1, 1, 1, 1, 1, 1, 0, 2, -1, 0,-1,-1, & + 0, 0, 0, 1, 2, 0, 1, 1, 1, 1, 0, 1, -1,-1,-1,-1, & + 0, 0, 1, 0, 2, 0, 1, 1, 0,-1, 0, 0, 0, 1, 0, 1, & + 0, 0, 0, 1, -1, 1,-1, 0, 0, 0,-1, 0, -1,-1, 0,-1, & + 1, 1, 0, 1, 0, 0, 0, 1, -1, 0,-1, 0, 0, 1, 1, 0, & + 1, 0, 0, 1, 0, 0, 1, 1, 0, 1, 0, 1, -1,-1,-1,-1, & + 1, 0, 0, 1, -1, 0,-1, 0, -1,-1, 0, 0, 1, 1, 1, 1, & + 1, 0, 1, 0, 0, 1, 0, 0, 0, 1, 1, 1, 1, 0, 0, 1, & + 0, 1, 0, 1, -1,-1, 0, 0, 0, 0, 1, 0, -1, 0,-1,-1, & +!---------------- 7 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 1, 0, 1, 1, 0, 1, 1, 0, 0, 1, -1,-1,-1,-2, & + 0, 1, 0, 1, 2, 1, 1, 1, 1, 0, 1, 1, -1, 0, 0,-1, & + 0, 0, 1, 0, 2, 0, 1, 1, 0,-1, 0, 0, 0, 1, 0, 1, & + 0, 0, 0, 1, 0, 0, 1, 0, 1,-1, 1, 0, 1, 1, 0, 1, & + 1, 1, 0, 1, 0, 0, 0, 1, -1, 0,-1, 0, 0, 1, 1, 0, & + 1, 0, 0, 1, 0,-1, 0,-1, 0, 0,-1,-1, 1, 1, 1, 1, & + 1, 0, 0, 1, -1, 0,-1, 0, -1,-1, 0, 0, 1, 1, 1, 1, & + 1, 0, 1, 0, 0,-1,-1,-1, 0,-1, 0, 0, -1, 0, 0,-1, & + 0, 1, 0, 1, 0, 0,-1, 0, 1, 1, 0, 0, 1, 0, 1, 1, & +!---------------- 8 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 0, 0, -1,-1, 0,-2, -1,-1,-1,-1, 1, 0, 1, 1, & + 0, 0, 0, 1, -2, 0,-1,-1, -1,-1,-1,-1, 1, 1, 0, 1, & + 1, 1, 0, 1, -1, 0,-1, 0, -1, 0,-1,-1, 1,-1, 0, 0, & + 1, 0, 0, 1, 1, 0, 1, 0, 0,-1, 0,-1, 0, 1,-1, 0, & + 1, 0, 0, 0, 0,-1, 0, 0, 0, 0,-1, 1, 1, 1, 1, 1, & + 0, 1, 0, 0, 0, 0, 1, 0, 1, 1, 1, 2, 1, 0, 0, 0, & + 0, 0, 1, 0, -2,-1,-1,-1, 0,-1, 0, 0, 0, 0, 0,-1, & + 0, 0, 0, 1, -1, 1, 0, 0, 0, 0, 1, 0, -1,-1,-1,-1, & + 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0,-1, 0,-1, 1, 0, & +!---------------- 9 + 1, 0, 1, 1, 1, 1, 0, 1, 0, 1, 0, 1, 0, 0, 1,-1, & + 1, 0, 0, 0, 1, 0, 1, 1, 1, 1, 1, 1, -1,-1, 0,-2, & + 0, 1, 0, 0, 2, 1, 1, 2, 1, 0, 0, 0, -1, 0,-1, 0, & + 1, 1, 0, 1, -1, 0,-1, 0, -1, 0,-1,-1, 1,-1, 0, 0, & + 1, 0, 0, 1, 0, 1, 0, 1, -1, 0,-1, 0, 0,-1, 1, 0, & + 1, 0, 0, 0, 0,-1, 0, 0, 0, 0,-1, 1, 1, 1, 1, 1, & + 0, 1, 0, 0, -1,-1,-1,-2, 0, 0,-1, 0, -1, 0, 0, 0, & + 0, 0, 1, 0, 0, 1, 0, 0, 2, 1, 1, 1, 0, 0, 0, 1, & + 0, 0, 0, 1, -1, 1, 0, 0, 0, 0, 1, 0, -1,-1,-1,-1, & + 1, 1, 1, 1, 0, 0, 0, 1, -1, 0, 0, 0, 0, 1,-1, 0, & +!---------------- 10 + 0, 1, 0, 0, 1, 1, 0, 2, -1, 0,-1, 0, 0, 0, 1, 0, & + 1, 0, 1, 0, 1, 0, 0, 1, 1, 1, 1, 2, -1,-1, 0,-1, & + 0, 1, 0, 1, -2,-1,-1,-1, -1, 0,-1,-1, 1, 0, 0, 1, & + 1, 1, 1, 1, -1, 0, 0,-1, -1, 0, 0, 0, 1,-1, 1, 0, & + 0, 0, 0, 1, 1, 1, 0, 1, 0, 0,-1, 0, 1,-1, 1, 0, & + 0, 1, 0, 1, 0, 0,-1, 0, -1,-1,-1, 0, -1, 0, 0,-1, & + 0, 1, 0, 0, -1,-1,-1,-2, 1, 0, 0, 0, 0, 0, 1, 0, & + 1, 0, 1, 1, 1, 1, 1, 0, 1, 1, 0, 1, -1, 0, 0, 0, & + 1, 0, 1, 1, 0, 1, 0, 1, 0, 1, 1, 0, 1, 0, 0, 0, & + 1, 0, 1, 0, 0, 1, 0, 0, 0, 0,-1,-1, -1,-1, 0,-1, & +!---------------- 11 + 1, 1, 1, 1, -1, 0, 0,-1, 0, 0, 0,-1, 0, 1,-1, 1, & + 0, 0, 1, 0, 0, 0, 0,-1, 0,-1, 0,-1, 2, 1, 1, 2, & + 0, 1, 0, 0, -1, 0,-1, 0, -1, 0, 0, 0, 2, 1, 1, 2, & + 1, 1, 0, 1, -1, 0,-1,-1, -1, 0,-1, 0, 1,-1, 0, 0, & + 1, 0, 0, 0, 0, 1, 0, 0, -1, 0,-1,-1, 0,-1, 1,-1, & + 0, 1, 0, 1, 0, 0, 1, 0, -1, 0, 0,-1, -1,-1,-1, 0, & + 1, 0, 0, 1, 0, 1, 0, 1, 1, 1, 1, 1, 0, 0,-1,-1, & + 1, 0, 1, 1, 1, 0, 0, 0, 1, 1, 0, 1, -1,-1,-1, 0, & + 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, 1, 0, 1,-1, 0, 0, & + 1, 0, 1, 0, 1, 1, 0, 1, 0, 1, 0, 0, 0, 0, 1, 1/ +data umat12/& +!---------------- 12 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 1, 1,-1,-1, 0,-2, 0,-2, -2, 0, 0, 0, 0, 0, 0, 2, & + 0, 0, 2, 0, -1, 1,-1,-1, -1, 1,-1, 1, 0,-2, 0, 0, & +!---------------- 13 + 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, & + 1, 1, 1, 1, 1,-1, 1, 1, 0, 0,-2, 0, -2, 0, 0, 0, & + 1, 1,-1, 1, 1,-1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & +!---------------- 14 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, 1, 1, 1, 1, & + 1, 1,-1,-1, 0,-2, 0,-2, 1,-1, 1, 1, -1, 1, 1, 1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1,-1, 1, 1, 1, 1, 1, 1, & +!---------------- 15 + 0, 2, 0, 2, 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, & + 1, 1,-1, 1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, & + 1,-1,-1,-1, -1, 1,-1, 1, 0, 2, 0, 0, -1,-1, 1,-1, & + 1,-1,-1,-1, 1,-1, 1, 1, -1, 1,-1, 1, 0, 2, 0, 0, & +!---------------- 16 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 0, 0, 2, 0, 2, 0, 0, 0, 0, 0, 0, 2, -1,-1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1, 1,-1, 1, 1,-1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1,-1, 1,-1, 1,-1,-1,-1, & +!---------------- 17 + 0, 2, 0, 2, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0,-2,-2, & + 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, 1, 1,-1, 1, 1,-1,-1,-1, & + !---------------- 18 + 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, & + 0, 0, 2, 2, -1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & + 0, 2, 0, 2, 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, & + 0, 0, 2, 0, -2, 0, 0, 0, 0, 2,-2, 0, 1,-1,-1,-1, & +!---------------- 19 + 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, & + 1, 1,-1,-1, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, -1,-1, 1, 1, & + 1,-1, 1, 1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 2,-2, 0, & +!---------------- 20 + 0, 2, 0, 2, 1,-1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, & + 1, 1,-1,-1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 0, 0, 2, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1, 1,-1, 1,-1, 1, 1, & +!---------------- 21 + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, & + 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, & + 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, & + 1,-1,-1,-1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, & +!---------------- 22 + 0, 0, 2, 2, 1,-1, 1,-1, 0,-2, 0, 0, 1, 1,-1, 1, & + 0, 0, 0, 2, -2, 0, 0, 0, 0, 0, 2, 0, 1, 1,-1,-1, & + 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 2, 0, 2, & + 0, 2, 0, 0, 1, 1,-1, 1, -1,-1, 1, 1, -1,-1,-1,-1, & +!---------------- 23 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1, 1,-1,-1, -1, 1,-1, 1, 0, 0, 2, 2, -1,-1, 1,-1, & + 1,-1,-1,-1, -1, 1,-1, 1, -1,-1, 1, 1, 1, 1, 1, 1, & + 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 24 + 0, 0, 2, 2, 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1,-1, & + 1, 1, 1, 1, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 25 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, 1,-1,-1,-1, & + 0, 0, 0, 2, -1, 1, 1, 1, 1,-1, 1,-1, 1, 1,-1,-1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 26 + 0, 2,-2, 0, 1,-1,-1,-1, 0, 0, 0,-2, 1, 1, 1, 1, & + 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, -1,-1, 1,-1, & + 1, 1,-1, 1, -1,-1,-1,-1, 0, 0, 0,-2, -1, 1, 1, 1, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & +!---------------- 27 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1, 1, 0, 0,-2,-2, & + 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1, 1, 0,-2, 0,-2, & + 1,-1,-1,-1, -1, 1,-1,-1, -1, 1,-1, 1, 1, 1, 1, 1, & +!---------------- 28 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 1, 1,-1,-1, 0,-2, 0,-2, -2, 0, 0, 0, 0, 0, 0, 2, & + 0, 2, 0, 0, 1,-1, 1,-1, 1,-1, 1, 1, 0, 0,-2, 0, & +!---------------- 29 + 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, & + 1, 1, 1, 1, 1,-1, 1, 1, 0, 0,-2, 0, -2, 0, 0, 0, & + 1, 1,-1, 1, 1,-1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & +!---------------- 30 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, 1, 1, 1, 1, & + 1,-1, 1, 1, -1,-1, 1,-1, 0, 2, 0, 0, -1, 1,-1, 1, & + 1,-1,-1,-1, -1,-1, 1,-1, -1,-1, 1, 1, 1, 1, 1, 1, & +!---------------- 31 + 0, 2, 0, 2, 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1,-1, & + 1, 1,-1, 1, 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, & + 1,-1,-1,-1, -1, 1,-1, 1, 0, 2, 0, 0, -1,-1, 1,-1, & + 1,-1,-1,-1, 1,-1, 1, 1, -1, 1,-1, 1, 0, 2, 0, 0, & +!---------------- 32 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 0, 0, 0, 2, 1,-1,-1,-1, -1,-1, 1,-1, -1, 1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1, 1,-1, 1, 1,-1,-1,-1, & + 1, 1, 1, 1, -1,-1, 1, 1, -1,-1, 1,-1, 1,-1,-1,-1, & +!---------------- 33 + 0, 2, 0, 2, -1,-1, 1, 1, 0, 0, 2, 0, -1, 1,-1,-1, & + 1,-1, 1, 1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0,-2,-2, & + 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, -1,-1, 1,-1, & + 0, 0, 2, 0, -1,-1, 1, 1, 1, 1,-1, 1, 1,-1,-1,-1, & +!---------------- 34 + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, & + 0, 0, 2, 2, -1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & + 0, 2, 0, 2, 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, & + 1,-1, 1, 1, -1, 1, 1, 1, -1,-1, 1,-1, 1, 1,-1,-1, & +!---------------- 35 + 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, & + 1, 1,-1,-1, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, -1,-1, 1, 1, & + 1,-1, 1, 1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 2,-2, 0, & +!---------------- 36 + 0, 2, 0, 2, 1,-1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, & + 1, 1,-1,-1, 1,-1, 1,-1, -1,-1,-1,-1, 0, 0, 0, 2, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1, 1,-1, 1,-1, 1, 1, & +!---------------- 37 + 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, & + 1, 1,-1, 1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, -1,-1,-1,-1, 0, 2,-2, 0, & +!---------------- 38 + 0, 2, 0, 2, 1, 1,-1,-1, -1, 1,-1,-1, 0, 0, 2, 0, & + 1, 1,-1,-1, 0, 0, 2, 0, -2, 0, 0, 0, 0, 0, 0, 2, & + 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, 0, 2, 0, 2, & + 0, 2, 0, 0, 1, 1,-1, 1, -1,-1, 1, 1, -1,-1,-1,-1, & +!---------------- 39 + 0, 2, 0, 2, 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, & + 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, 1,-1,-1,-1, & + 1,-1,-1,-1, -1, 1,-1, 1, -1,-1, 1, 1, 1, 1, 1, 1, & + 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 40 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 1, 1, 1, 1, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1, 1,-1,-1, 1,-1, 1,-1, 0,-2, 0, 0, -2, 0, 0, 0, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 41 + 0, 0, 2, 2, 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1,-1, & + 1, 1, 1, 1, -1, 1,-1,-1, -1,-1, 1,-1, 1,-1,-1,-1, & + 1,-1, 1,-1, 0, 2, 0, 0, 1, 1,-1, 1, -1,-1,-1,-1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 42 + 0, 2,-2, 0, 1,-1,-1,-1, 0, 0, 0,-2, 1, 1, 1, 1, & + 1, 1,-1,-1, 0, 0,-2, 0, 1,-1, 1, 1, -1,-1, 1,-1, & + 1, 1,-1, 1, -1,-1,-1,-1, 0, 0, 0,-2, -1, 1, 1, 1, & + 0, 2,-2, 0, -1, 1, 1, 1, 1,-1, 1, 1, 1,-1, 1,-1, & + !---------------- 43 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 0, 0, 2, 0, -1,-1, 1, 1, -1, 1,-1, 1, 0, 0,-2,-2, & + 0, 2, 0, 0, 1, 1,-1, 1, 1,-1, 1, 1, 0,-2, 0,-2, & + 1, 1, 1, 1, -1, 1,-1, 1, -1, 1,-1,-1, 1,-1,-1,-1, & +!---------------- 44 + 0, 2,-2, 0, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 1,-1, 1,-1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0,-2, 0, & + 0, 0, 0, 2, -2, 0, 0, 0, 0,-2, 0,-2, 1, 1,-1,-1, & + 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, 0,-2, 0, 0, & +!---------------- 45 + 0, 0, 2, 2, 0,-2, 0, 0, -1,-1, 1,-1, -1, 1,-1, 1, & + 1,-1,-1,-1, 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, & + 2, 0, 0, 0, 0, 0, 0,-2, -1, 1, 1, 1, -1, 1,-1, 1, & + 1, 1,-1,-1, -1,-1,-1,-1, 0,-2, 2, 0, -1, 1, 1, 1, & +!---------------- 46 + 0, 2, 0, 2, 0, 0,-2, 0, 1, 1,-1,-1, 1,-1, 1, 1, & + 1, 1,-1, 1, -1, 1,-1,-1, 0, 0, 2, 0, -1,-1, 1, 1, & + 1,-1, 1, 1, 0,-2, 0,-2, 1, 1,-1,-1, -1, 1,-1, 1, & + 1, 1, 1, 1, 0, 2,-2, 0, 1,-1,-1,-1, -1,-1, 1,-1, & +!---------------- 47 + 0, 2, 0, 2, 0, 0, 2, 0, 1,-1, 1, 1, 1, 1,-1,-1, & + 1, 1,-1, 1, 0, 0, 2, 2, 1,-1, 1,-1, -1,-1,-1,-1, & + 1,-1,-1,-1, -1, 1,-1,-1, 0, 2, 0, 2, -1,-1, 1, 1, & + 1, 1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, -1, 1,-1,-1, & +!---------------- 48 + 0, 2,-2, 0, -1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1,-1, 1,-1, 1,-1, 0, 0, 2, 2, -2, 0, 0, 0, & + 2, 0, 0, 0, 0, 2, 0, 2, -1, 1,-1,-1, -1,-1, 1,-1, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 49 + 0, 0, 2, 2, -1, 1,-1, 1, 1, 1,-1, 1, 0,-2, 0, 0, & + 1, 1,-1, 1, 1,-1,-1,-1, -1,-1, 1, 1, 0, 0, 2, 0, & + 2, 0, 0, 0, 0, 2, 0, 2, -1,-1, 1, 1, -1,-1,-1,-1, & + 1,-1, 1, 1, 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 50 + 0, 2,-2, 0, 1, 1, 1, 1, 0, 0, 0, 2, 1,-1,-1,-1, & + 1,-1, 1, 1, -1,-1, 1,-1, 0, 0,-2,-2, -1, 1,-1, 1, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, & +!---------------- 51 + 0, 0, 2, 2, -1,-1, 1,-1, 0,-2, 0, 0, -1, 1,-1, 1, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 2, 0, 0, -2, 0, 0, 0, 0,-2, 0,-2, 1,-1, 1, 1, & + 0, 0, 2, 0, -2, 0, 0, 0, 0, 2,-2, 0, 1,-1,-1,-1, & +!---------------- 52 + 0, 0, 2, 2, 1, 1,-1, 1, 0, 2, 0, 0, 1,-1, 1,-1, & + 1,-1,-1,-1, 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, & + 2, 0, 0, 0, 0, 0, 0,-2, -1, 1, 1, 1, -1, 1,-1, 1, & + 1, 1,-1,-1, -1,-1,-1,-1, 0,-2, 2, 0, -1, 1, 1, 1, & +!---------------- 53 + 0, 2,-2, 0, -1, 1, 1, 1, 0, 0, 0, 2, -1,-1,-1,-1, & + 0, 0, 2, 0, 2, 0, 0, 0, 0, 0,-2,-2, -1, 1,-1, 1, & + 0, 0, 0, 2, -2, 0, 0, 0, 0,-2, 0,-2, 1, 1,-1,-1, & + 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0, 0,-2, 0, 0, & +!---------------- 54 + 0, 2, 0, 2, -1, 1,-1,-1, 0, 0,-2, 0, -1,-1, 1, 1, & + 1, 1,-1, 1, 0, 0, 2, 2, 1,-1, 1,-1, -1,-1,-1,-1, & + 1, 1,-1,-1, 0,-2, 0,-2, 1,-1, 1, 1, -1, 1, 1, 1, & + 1, 1, 1, 1, -1,-1, 1, 1, 0, 0,-2, 0, -1, 1,-1,-1, & +!---------------- 55 + 0, 2, 0, 2, -1,-1, 1, 1, 0, 0, 2, 0, -1, 1,-1,-1, & + 1, 1,-1, 1, -1, 1,-1,-1, 0, 0, 2, 0, -1,-1, 1, 1, & + 1,-1, 1,-1, -1,-1, 1, 1, 0, 2, 0, 2, -1, 1,-1,-1, & + 1, 1, 1, 1, 0, 2,-2, 0, 1,-1,-1,-1, -1,-1, 1,-1, & +!---------------- 56 + 0, 0, 2, 2, -1,-1, 1,-1, 1,-1, 1,-1, 0, 2, 0, 0, & + 1, 1,-1, 1, 1,-1,-1,-1, -1,-1, 1, 1, 0, 0, 2, 0, & + 2, 0, 0, 0, 0, 2, 0, 2, -1,-1, 1, 1, -1,-1,-1,-1, & + 2, 0, 0, 0, 0,-2, 2, 0, -1, 1, 1, 1, -1, 1,-1,-1, & +!---------------- 57 + 0, 2,-2, 0, -1,-1,-1,-1, 1,-1,-1,-1, 0, 0, 0, 2, & + 2, 0, 0, 0, 0, 0,-2,-2, -1, 1,-1, 1, -1,-1, 1, 1, & + 2, 0, 0, 0, 0, 2, 0, 2, -1, 1,-1,-1, -1,-1, 1,-1, & + 1, 1, 1, 1, 1,-1, 1,-1, -1, 1,-1,-1, 0, 0,-2, 0, & +!---------------- 58 + 0, 2,-2, 0, 1, 1, 1, 1, -1, 1, 1, 1, 0, 0, 0,-2, & + 1, 1,-1, 1, 0, 0, 2, 2, -2, 0, 0, 0, 0, 0, 0,-2, & + 0, 2, 0, 0, -2, 0, 0, 0, 0,-2, 0,-2, 1,-1, 1, 1, & + 1,-1,-1,-1, 0, 2,-2, 0, -2, 0, 0, 0, 0, 0, 2, 0, & +!---------------- 59 + 0, 2,-2, 0, 0, 0, 0,-2, -1,-1,-1,-1, -1, 1, 1, 1, & + 1,-1, 1, 1, -1,-1, 1,-1, 0, 0,-2,-2, -1, 1,-1, 1, & + 2, 0, 0, 0, 0,-2, 0, 0, -1, 1,-1, 1, -1, 1, 1, 1, & + 1,-1, 1,-1, 1, 1, 1, 1, 0, 2,-2, 0, -2, 0, 0, 0/ +data umats/& ! Divide all these elements by 2 for simplicity: + 0, 0, 0, 2, 0, 0,-2, 0, 0,-2, 0, 0, 2, 0, 0, 0, & + 0, 0, 2, 0, 0, 0, 0,-2, 2, 0, 0, 0, 0,-2, 0, 0, & + 0, 2, 0, 0, 2, 0, 0, 0, 0, 0, 0,-2, 0, 0,-2, 0, & + 0, 0, 0, 2, 0, 0, 2, 0, 0, 2, 0, 0, 2, 0, 0, 0, & + 0, 0, 2, 0, 0, 0, 0, 2, 2, 0, 0, 0, 0, 2, 0, 0, & + 0, 2, 0, 0, 2, 0, 0, 0, 0, 0, 0, 2, 0, 0, 2, 0/ + +data nei/ & +!===== 0--3: +18,12,25,43,32,56,36,37,38,42, & +34,28,41,27,14,48,13,21,17,19, & +18,12,23,43,30,49,29,37,33,35, & +34,28,39,27,16,57,20,21,22,26, & +!---- 4--7: +20,54,52,22,40,24,32,25,42,31, & +36,46,50,38,15,40,14,41,19,24, & +13,48,45,17,31,15,30,23,35,40, & +29,55,50,33,24,31,16,39,26,15, & +!---- 8--9 +26,57,48,19,43,20,33,38,13,28, & +42,56,53,35,27,36,22,17,29,12, & +!---- 10: +39,14,23,37,21,30,16,32,25,41, & +!---- 11: +34,34,18,18,18,34,34,18,34,18, & +!==== 12--27: +27, 0, 2, 9,14,13,15,16,24,20, & ! 12 +19, 8, 1, 6,15,12,14,17,25,21, & +16, 5,10, 1,12,15,13,18,26,22, & +39, 5, 7, 6,13,14,12,19,27,23, & +!-- +14,10, 7, 3,18,17,19,12,20,24, & ! 16 +55, 6, 9, 1,19,16,18,13,21,25, & +34, 0, 2,11,16,19,17,14,22,26, & +13, 1, 5, 8,17,18,16,15,23,27, & +!-- +26, 3, 8, 4,22,21,23,24,16,12, & ! 20 +37, 1, 3,10,23,20,22,25,17,13, & +46, 9, 4, 3,20,23,21,26,18,14, & +40,10, 6, 2,21,22,20,27,19,15, & +!-- +41, 5, 7, 4,26,25,27,20,12,16, & ! 24 +31, 4,10, 0,27,24,26,21,13,17, & +20, 7, 3, 8,24,27,25,22,14,18, & +12, 1, 3, 9,25,26,24,23,15,19, & +!----- 28--43: +43, 1, 3, 8,30,29,31,32,40,36, & !28 +35, 9, 2, 7,31,28,30,33,41,37, & +32, 6,10, 2,28,31,29,34,42,38, & +25, 6, 4, 7,29,30,28,35,43,39, & +!-- +30,10, 4, 0,34,33,35,28,36,40, & ! 32 +54, 7, 8, 2,35,32,34,29,37,41, & +18, 1, 3,11,32,35,33,30,38,42, & +29, 2, 6, 9,33,34,32,31,39,43, & +!-- +42, 0, 9, 5,38,37,39,40,32,28, & ! 36 +21, 2, 0,10,39,36,38,41,33,29, & +50, 8, 5, 0,36,39,37,42,34,30, & +15,10, 7, 3,37,38,36,43,35,31, & +!-- +23, 6, 4, 5,42,41,43,36,28,32, & ! 40 +24, 5,10, 1,43,40,42,37,29,33, & +36, 4, 0, 9,40,43,41,38,30,34, & +28, 2, 0, 8,41,42,40,39,31,35, & +!------ 44--59: +53, 9, 4, 6,45,46,47,56,48,52, & ! 44 +17, 6, 0, 4,44,47,46,57,49,53, & +22, 1, 9, 5,47,44,45,58,50,54, & +38, 6, 8, 2,46,45,44,59,51,55, & +!-- +17, 8, 6, 1,49,50,51,52,44,56, & ! 48 +33, 2, 7, 9,48,51,50,53,45,57, & +38, 7, 3, 5,51,48,49,54,46,58, & +58, 7, 5, 8,50,49,48,55,47,59, & +!-- +22, 4, 2, 6,53,54,55,48,56,44, & ! 52 +44, 9, 6, 4,52,55,54,49,57,45, & +33, 4, 8, 0,55,52,53,50,58,46, & +17, 3, 9, 7,54,53,52,51,59,47, & +!-- +38, 0, 5, 9,57,58,59,44,52,48, & ! 56 +22, 8, 4, 3,56,59,58,45,53,49, & +51, 5, 7, 8,59,56,57,46,54,50, & +33, 5, 1, 7,58,57,56,47,55,51/ +data dcol10/ & +!==== 0--3: + 4, 3,13, 4,14, 0, 0, 3, 2, 5, & + 8, 6,11, 8,13, 0, 0, 6, 4,10, & ! previous row *2 + 1,12, 7, 1,11, 0, 0,12, 8, 5, & ! + 2, 9,14, 2, 7, 0, 0, 9, 1,10, & ! +!---- 4--7: +13, 2, 1, 7, 1,14, 0, 0, 2, 6, & ! previous row *2, except cols 1 and 2 +11, 4, 2,14, 2,13, 0, 0, 4,12, & + 7, 3, 4,13, 4,11, 0, 0, 8, 9, & +14, 1, 3,11, 8, 7, 0, 0, 1, 3, & +!---- 8--9: + 2, 1, 4, 8, 5, 1, 9, 6, 4, 0, & + 4, 2, 3, 1,10, 2, 3,12, 8, 0, & +!---- 10: +11,14,13,10, 5,13,11, 7, 7,14, & +!---- 11: + 2, 8,13,10, 7,11,14, 1, 5, 4/ +data dcol12/ & +!===== 12--27: +10,12, 3, 0, & ! 12 + 4,11, 0, 8, & ! 13 +12, 0, 1, 2, & ! 14 +12,13,12, 4, & ! 15 +!-- + 3, 4, 0, 8, & ! 16 + 1, 2, 3,11, & ! 17 +10,11,14, 2, & ! 18 +11, 5,11, 7, & ! 19 +!-- + 1, 0,14, 2, & ! 20 + 5, 9, 6,10, & ! 21 + 4,12, 8,14, & ! 22 + 9, 2, 0, 8, & ! 23 +!-- + 3, 3, 7, 1, & ! 24 + 6, 0, 8, 2, & ! 25 +14,14, 5,13, & ! 26 + 5, 7,13, 5, & ! 27 +!------ 28--43: + 5, 9, 6, 0, & ! 28 + 8, 7, 0, 1, & ! 29 + 9, 0, 2, 4, & ! 30 + 9,11, 9, 8, & ! 31 +!-- + 6, 8, 0, 1, & ! 32 + 2, 4, 6, 7, & ! 33 + 5, 7,13, 1, & ! 34 + 7,10, 7,14, & ! 35 +!-- + 2, 0,13, 4, & ! 36 +10, 3,12, 5, & ! 37 + 3, 9, 1,13, & ! 38 + 3, 4, 0, 1, & ! 39 +!-- + 6, 6,14, 2, & ! 40 +12, 0, 1, 4, & ! 41 +13,13,10,11, & ! 42 +10,14,11,10, & ! 43 +!------- 44--59: + 1, 3, 4, 2, & ! 44 + 9,11, 5, 9, & ! 45 +11, 5, 8,11, & ! 46 + 7, 7, 1,10, & ! 47 +!-- + 4,11,12, 0, & ! 48 + 8, 0, 9, 7, & ! 49 +12,12,10,13, & ! 50 + 2, 4, 8, 6, & ! 51 +!-- + 6,14, 5, 6, & ! 52 + 4,12, 1, 8, & ! 53 +13,13, 4,10, & ! 54 +14, 5, 2,14, & ! 55 +!-- + 2, 0, 6,13, & ! 56 + 1,14, 3, 0, & ! 57 + 3, 1, 2, 9, & ! 58 + 3, 3,10, 7/ ! 59 +data nei0a/45,54, 46,59, 52,47, 55,50/ ! k=0--3 +data nei0b/57,53, 44,45, 58,56, 59,51,& ! k=4--5 + 44,47, 53,52, 51,49, 58,59,& ! k=6--7 + 54,58, 47,51, 44,46, 55,49/ ! k=8--9 +data nei17/48,45/ +data nei22/57,52/ +data nei33/59,49/ +data nei38/56,47/ +data jcora/6,3, 2,5, 6,3, 2,5/ ! k=0--3 +data jcorb/6,3,6,3, 2,5,2,5, 4,1,6,3, 2,5,6,3, 6,3,6,3, 2,5,6,3/ +data tcors/2,0,0,0, 0,2,0,0, 0,0,2,0, 0,0,0,2, & ! twice the identity + 1,1,-1,-1, 1,-1,-1,1, -1,1,-1,1, 1,1,1,1, & ! A_1 + 1,-1,-1,-1, -1,-1,-1,1, 1,-1,1,1, -1,-1,1,-1, & ! A_2 + 1,-1,1,-1, -1,-1,-1,-1, -1,-1,1,1, -1,1,1,-1, & ! B_1 + 1,-1,1,1, 1,1,-1,1, 1,-1,-1,-1, 1,1,1,-1, & ! B_2 + 1,1,1,1, -1,1,-1,1, 1,-1,-1,1, 1,1,-1,-1, & ! C_1 + 1,1,-1,1, 1,-1,1,1, -1,-1,-1,1, -1,1,1,1, & + 2,0,2,0, 2,2,0,2, 0,0,0,2, -2,-2,-2,-2, & ! to 11, jcol=1 + 2,0,2,2, 2,0,0,0, -2,-2,-2,-2, -2,0,0,-2, & ! to 11 jcol=2 + 0,2,0,0, -2,0,-2,0, 2,0,0,2, 0,-2,0,-2, & ! to 11 jcol=3 + 2,2,0,2, -2,0,-2,-2, 0,-2,0,-2, 0,0,2,0, & ! to 11 jcol=4 + 1,1,1,-1, -1,1,1,1, -1,-1,1,-1, 1,-1,1,1, & ! >11 to>43,jcol=1 + 1,-1,-1,1, 1,1,-1,-1, 1,1,1,1, -1,1,-1,1/ ! >11 to>43,jcol=2 +data kcor10a5/0,2,1, 0,1,2, 0,2,1, 0,1,2/ +data kcor10b1/0,1,2, 0,2,1, 1,2,0, 0,2,1, 1,0,2, 1,2,0/ +data kcor10b2/0,2,1, 0,1,2, 0,2,1, 1,2,0, 0,1,2, 2,1,0/ + +data kcor12b0/0,1,2,2, 1,2,0,0, 2,0,1,2, 1,1,0,0, & + 0,1,2,2, 1,2,0,0, 2,0,1,2, 1,1,0,0, & + 0,1,2,2, 0,1,0,1, 1,0,2,2, 1,0,0,0/ +data kcor17c0/0,1,2/ +data kcor22c0/2,1,0/ +data kcor33c0/0,2,1/ +data kcor38c0/0,1,2/ +data kcor44c0/1,0,2/ +data kcor51c0/2,1,0/ +data kcor53c0/1,0,2/ +data kcor58c0/1,0,2/ +data twt10a5/ & + 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! + 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! + 1, 0,-1,-1, 0, 2,-1, 0, 0,-1/ ! +data twt10b1/ & + 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! + 1, 2, 0,-1, 0, 0, 0,-1,-1,-1, & ! + 0, 2, 1, 0,-1,-1, 0, 0,-1,-1/ +data twt10b2/ & +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! +-1, 0, 2, 0,-1, 0,-1, 1,-1, 0, & ! + 0, 1, 2, 0,-1,-1, 0, 0,-1,-1/ ! +data twt12c0/ & + 2, 0, 1, 0,-1, 0,-1,-1, 0,-1, & ! 0 + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 2, 1, 0, 0,-1,-1, 0,-1,-1, 0/ ! 0 +data qwt10a/ & +! -------------------------------------------- 0 + 2, 0,-1, 0, 1, 0,-1,-1,-1, 0, & ! 0 + 0, 2, 1, 0,-1,-1, 0, 0,-1,-1, & ! 1 +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2 + 0,-1, 0, 2, 1,-1,-1,-1, 0, 0, & ! 3 + 0,-1,-1, 0, 2,-1, 0, 0,-1, 1, & ! 4 + 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! 5 +-1, 0,-1, 0,-1, 0, 2,-1, 1, 0, & ! 6 +-1, 0, 1, 0,-1, 0,-1, 2,-1, 0, & ! 7 + 0,-1,-1, 0,-1, 1, 0, 0, 2,-1, & ! 8 +-1,-1, 0,-1, 0, 0, 0, 1,-1, 2/ ! 9 +data qwt10b/ & +! -------------------------------------------- 4 + 2, 0,-1,-1, 0, 1,-1, 0, 0,-1, & ! 0 + 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! 1 +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2 +-1, 0, 1, 2, 0,-1,-1, 0, 0,-1, & ! 3 + 0,-1, 0, 1, 2,-1,-1,-1, 0, 0, & ! 4 + 0,-1,-1, 0,-1, 2, 0, 0, 1,-1, & ! 5 +-1, 0,-1,-1, 0,-1, 2, 0, 0, 1, & ! 6 +-1,-1, 0,-1, 0, 0, 0, 2,-1, 1, & ! 7 +-1, 0,-1, 0,-1, 0, 1,-1, 2, 0, & ! 8 +-1,-1, 0,-1, 0, 0, 0, 1,-1, 2/ ! 9 +data qwt10c/ & +! -------------------------------------------- 8 + 2, 0,-1,-1, 0, 1,-1, 0, 0,-1, & ! 0 + 1, 2, 0,-1, 0, 0, 0,-1,-1,-1, & ! 1 +-1, 0, 2, 1, 0,-1,-1, 0, 0,-1, & ! 2 +-1,-1, 0, 2, 0, 0, 0,-1, 1,-1, & ! 3 + 0,-1,-1, 0, 2,-1, 0, 0,-1, 1, & ! 4 + 1, 0,-1,-1, 0, 2,-1, 0, 0,-1, & ! 5 + 0, 1, 0,-1,-1,-1, 2,-1, 0, 0, & ! 6 +-1, 0, 1, 0,-1, 0,-1, 2,-1, 0, & ! 7 +-1,-1, 0, 1, 0, 0, 0,-1, 2,-1, & ! 8 + 0,-1,-1, 0, 1,-1, 0, 0,-1, 2/ ! 9 +data qwt10d/ & +! -------------------------------------------- 10 + 2, 1, 0,-1, 0, 0, 0,-1,-1,-1, & ! 0 + 0, 2, 0,-1,-1,-1, 1,-1, 0, 0, & ! 1 +-1, 0, 2, 0,-1, 0,-1, 1,-1, 0, & ! 2 + 0,-1, 0, 2, 1,-1,-1,-1, 0, 0, & ! 3 + 0,-1, 0, 1, 2,-1,-1,-1, 0, 0, & ! 4 + 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! 5 + 0, 1, 0,-1,-1,-1, 2,-1, 0, 0, & ! 6 + 0,-1, 0,-1,-1, 1,-1, 2, 0, 0, & ! 7 + 0,-1,-1, 0,-1, 1, 0, 0, 2,-1, & ! 8 +-1, 0,-1,-1, 0,-1, 1, 0, 0, 2/ ! 9 +data qwt10e/ & +! -------------------------------------------- 11 + 2, 0,-1, 0, 1, 0,-1,-1,-1, 0, & ! 0 + 0, 2, 1, 0,-1,-1, 0, 0,-1,-1, & ! 1 + 0, 1, 2, 0,-1,-1, 0, 0,-1,-1, & ! 2 +-1,-1, 0, 2, 0, 0, 0,-1, 1,-1, & ! 3 + 1, 0,-1, 0, 2, 0,-1,-1,-1, 0, & ! 4 + 0,-1, 0,-1,-1, 2,-1, 1, 0, 0, & ! 5 +-1, 0,-1,-1, 0,-1, 2, 0, 0, 1, & ! 6 + 0,-1, 0,-1,-1, 1,-1, 2, 0, 0, & ! 7 +-1,-1, 0, 1, 0, 0, 0,-1, 2,-1, & ! 8 +-1, 0,-1,-1, 0,-1, 1, 0, 0, 2/ ! 9 +data qwt12a/ & +! -------------------------------------------- 12 + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 1, 2, 0, 0,-1,-1, 0,-1,-1, 0, & ! 1 + 1, 0, 2, 0,-1, 0,-1,-1, 0,-1, & ! 2 + 1, 0, 0, 2, 0,-1,-1, 0,-1,-1, & ! 3 +-1,-1,-1,-1, 2, 1, 1, 0, 0, 0, & ! 4 +-1,-1,-1,-1, 1, 2, 1, 0, 0, 0, & ! 5 +-1,-1,-1,-1, 1, 1, 2, 0, 0, 0, & ! 6 +-1,-1,-1,-1, 0, 0, 0, 2, 1, 1, & ! 7 +-1,-1,-1,-1, 0, 0, 0, 1, 2, 1, & ! 8 +-1,-1,-1,-1, 0, 0, 0, 1, 1, 2/ ! 9 +data qwt12b/ & +! -------------------------------------------- 44 + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 1, 2, 0, 0,-1,-1, 0,-1,-1, 0, & ! 1 + 1, 0, 2, 0,-1, 0,-1,-1, 0,-1, & ! 2 + 1, 0, 0, 2, 0,-1,-1, 0,-1,-1, & ! 3 +-1,-1,-1,-1, 2, 1, 1, 0, 0, 0, & ! 4 +-1,-1,-1,-1, 1, 2, 1, 0, 0, 0, & ! 5 +-1,-1,-1,-1, 1, 1, 2, 0, 0, 0, & ! 6 +-1,-1,-1,-1, 0, 0, 0, 2, 1, 1, & ! 7 +-1,-1,-1,-1, 0, 0, 0, 1, 2, 1, & ! 8 +-1,-1,-1,-1, 0, 0, 0, 1, 1, 2/! 9 +data qwt12b0/ & + 2, 0, 0, 1, 0,-1,-1, 0,-1,-1, & ! 0 + 2, 1, 0, 0,-1,-1, 0,-1,-1, 0, & ! 12 + 2, 0, 1, 0,-1, 0,-1,-1, 0,-1/! 0 +data tperms/ & +0,1,2,3,4,5,6,7,8,9, & +9,8,1,7,3,0,2,5,6,4, & ! 1 +6,4,5,1,9,7,8,0,2,3, & ! 2 +7,3,8,9,1,2,0,5,6,4, & ! 3 +4,6,3,5,9,7,8,2,0,1, & ! 4 +8,9,7,2,0,3,1,5,6,4, & ! 5 +5,2,6,4,9,7,8,3,1,0, & ! 6 +8,5,7,2,3,6,0,9,1,4, & ! 7 +1,6,9,7,2,0,8,4,5,3, & ! 8 +5,0,4,9,7,8,1,3,6,2, & ! 9 +6,8,3,4,9,1,5,2,0,7, & ! 10 +0,5,4,6,9,7,8,1,3,2, & ! 11 +0,7,9,8,2,1,3,5,6,4/ ! 12 +data perm10/ & +! -------------------------------- 0 +1,9,8,2,0,6,7,4,5,3, & ! 0 +9,1,0,3,7,8,6,2,4,5, & ! 1 +6,4,3,0,1,8,5,7,2,9, & ! 2 +1,9,8,2,0,6,4,7,5,3, & ! 3 +4,5,9,7,3,6,2,1,8,0, & ! 4 +9,7,5,2,8,1,3,6,0,4, & ! 5 +5,6,4,3,7,2,1,8,0,9, & ! 6 +9,1,0,3,4,8,6,2,7,5, & ! 7 +1,9,5,4,6,0,7,2,3,8, & ! 8 +9,4,3,7,8,1,5,0,6,2, & ! 9 +! -------------------------------- 1 +1,9,8,2,0,6,7,4,5,3, & ! 0 +9,1,0,3,7,8,6,2,4,5, & ! 1 +6,4,3,0,1,8,5,7,2,9, & ! 2 +2,5,6,1,0,8,7,4,9,3, & ! 3 +7,9,5,4,3,8,1,2,6,0, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +9,8,7,3,4,1,2,6,0,5, & ! 6 +5,2,0,3,7,6,8,1,4,9, & ! 7 +2,5,9,7,8,0,4,1,3,6, & ! 8 +5,7,3,4,6,2,9,0,8,1, & ! 9 +! -------------------------------- 2 +2,5,6,1,0,8,4,7,9,3, & ! 0 +5,2,0,3,4,6,8,1,7,9, & ! 1 +8,7,3,0,2,6,9,4,1,5, & ! 2 +2,5,6,1,0,8,7,4,9,3, & ! 3 +7,9,5,4,3,8,1,2,6,0, & ! 4 +9,7,5,2,8,1,3,6,0,4, & ! 5 +9,8,7,3,4,1,2,6,0,5, & ! 6 +5,2,0,3,7,6,8,1,4,9, & ! 7 +2,5,9,7,8,0,4,1,3,6, & ! 8 +5,7,3,4,6,2,9,0,8,1, & ! 9 +! -------------------------------- 3 +2,5,6,1,0,8,4,7,9,3, & ! 0 +5,2,0,3,4,6,8,1,7,9, & ! 1 +8,7,3,0,2,6,9,4,1,5, & ! 2 +1,9,8,2,0,6,4,7,5,3, & ! 3 +4,5,9,7,3,6,2,1,8,0, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +5,6,4,3,7,2,1,8,0,9, & ! 6 +9,1,0,3,4,8,6,2,7,5, & ! 7 +1,9,5,4,6,0,7,2,3,8, & ! 8 +9,4,3,7,8,1,5,0,6,2, & ! 9 +! -------------------------------- 4 +3,4,6,8,7,0,5,1,2,9, & ! 0 +9,1,6,4,8,7,0,5,3,2, & ! 1 +7,9,1,0,3,5,8,6,2,4, & ! 2 +6,1,0,2,5,7,9,3,8,4, & ! 3 +5,6,1,0,2,4,7,9,3,8, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +4,5,6,7,3,9,2,1,8,0, & ! 6 +4,8,9,7,3,6,2,1,5,0, & ! 7 +5,2,8,9,7,6,0,4,1,3, & ! 8 +7,6,1,9,8,3,5,0,4,2, & ! 9 +! -------------------------------- 5 +3,4,6,8,7,0,5,1,2,9, & ! 0 +4,3,7,9,5,6,0,8,1,2, & ! 1 +6,4,3,0,1,8,5,7,2,9, & ! 2 +6,1,0,2,5,7,9,3,8,4, & ! 3 +9,8,2,0,1,7,4,5,3,6, & ! 4 +4,6,8,2,5,3,1,7,0,9, & ! 5 +7,9,8,4,3,5,1,2,6,0, & ! 6 +4,8,9,7,3,6,2,1,5,0, & ! 7 +9,1,6,5,4,8,0,7,2,3, & ! 8 +4,8,2,5,6,3,9,0,7,1, & ! 9 +! -------------------------------- 6 +3,7,8,6,4,0,9,2,1,5, & ! 0 +0,2,8,9,1,3,5,7,4,6, & ! 1 +7,9,1,0,3,5,8,6,2,4, & ! 2 +8,2,0,1,9,4,5,3,6,7, & ! 3 +9,8,2,0,1,7,4,5,3,6, & ! 4 +7,8,6,1,9,3,2,4,0,5, & ! 5 +7,9,8,4,3,5,1,2,6,0, & ! 6 +7,6,5,4,3,8,1,2,9,0, & ! 7 +9,1,6,5,4,8,0,7,2,3, & ! 8 +4,8,2,5,6,3,9,0,7,1, & ! 9 +! -------------------------------- 7 +3,7,8,6,4,0,9,2,1,5, & ! 0 +4,3,7,9,5,6,0,8,1,2, & ! 1 +8,9,1,6,4,2,7,0,5,3, & ! 2 +8,2,0,1,9,4,5,3,6,7, & ! 3 +5,6,1,0,2,4,7,9,3,8, & ! 4 +7,8,6,1,9,3,2,4,0,5, & ! 5 +4,5,6,7,3,9,2,1,8,0, & ! 6 +7,6,5,4,3,8,1,2,9,0, & ! 7 +5,2,8,9,7,6,0,4,1,3, & ! 8 +7,6,1,9,8,3,5,0,4,2, & ! 9 +! -------------------------------- 8 +3,7,8,6,4,0,9,2,1,5, & ! 0 +0,1,6,5,2,3,9,4,7,8, & ! 1 +5,6,1,0,2,7,4,9,3,8, & ! 2 +8,6,4,3,7,2,1,5,0,9, & ! 3 +4,6,8,7,3,5,1,2,9,0, & ! 4 +0,1,6,7,3,2,9,5,8,4, & ! 5 +3,0,1,9,4,7,2,6,8,5, & ! 6 +5,2,0,3,7,6,8,1,4,9, & ! 7 +4,8,2,0,3,6,9,5,1,7, & ! 8 +1,6,8,2,0,9,4,7,5,3, & ! 9 +! -------------------------------- 9 +3,7,8,6,4,0,9,2,1,5, & ! 0 +0,3,7,8,2,1,4,9,6,5, & ! 1 +2,0,1,6,5,8,3,9,4,7, & ! 2 +8,6,4,3,7,2,1,5,0,9, & ! 3 +7,8,6,4,3,9,2,1,5,0, & ! 4 +0,1,6,7,3,2,9,5,8,4, & ! 5 +3,0,2,5,7,4,1,8,6,9, & ! 6 +9,1,0,3,4,8,6,2,7,5, & ! 7 +4,8,2,0,3,6,9,5,1,7, & ! 8 +2,8,6,1,0,5,7,4,9,3, & ! 9 +! -------------------------------- 10 +1,0,3,7,9,6,2,4,5,8, & ! 0 +5,2,8,7,6,4,0,9,3,1, & ! 1 +5,6,1,9,7,2,4,0,8,3, & ! 2 +2,5,4,3,0,8,9,6,7,1, & ! 3 +7,8,2,0,3,9,6,5,1,4, & ! 4 +8,9,1,6,7,2,4,0,5,3, & ! 5 +2,0,3,4,8,5,1,7,6,9, & ! 6 +3,7,9,8,4,0,5,1,2,6, & ! 7 +3,7,6,5,4,0,8,1,2,9, & ! 8 +6,1,9,4,5,7,0,8,3,2, & ! 9 +! -------------------------------- 11 +3,4,5,2,0,7,6,9,8,1, & ! 0 +7,3,0,1,9,8,4,2,6,5, & ! 1 +2,0,3,7,8,5,1,4,9,6, & ! 2 +9,5,4,3,7,1,2,6,0,8, & ! 3 +0,1,6,4,3,2,9,8,5,7, & ! 4 +4,6,1,9,5,3,8,0,7,2, & ! 5 +8,7,9,5,2,6,3,1,4,0, & ! 6 +1,9,7,8,6,0,5,3,2,4, & ! 7 +6,8,2,0,1,4,7,5,3,9, & ! 8 +5,2,8,6,4,9,0,7,1,3/ ! 9 +data perm12/ & +! -------------------------------- 12 +0,4,7,3,1,9,6,2,8,5, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +2,7,1,3,4,0,5,8,6,9, & ! 2 +4,3,0,9,7,5,2,6,1,8, & ! 3 +! -------------------------------- 13 +0,3,4,7,8,5,2,9,6,1, & ! 0 +3,8,2,4,0,7,5,9,1,6, & ! 1 +8,5,6,3,4,9,7,2,1,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 14 +0,9,1,6,5,2,8,4,3,7, & ! 0 +9,6,7,4,3,5,8,0,2,1, & ! 1 +6,9,1,8,5,0,4,3,2,7, & ! 2 +9,6,7,4,3,2,8,0,5,1, & ! 3 +! -------------------------------- 15 +0,5,2,8,9,1,6,7,3,4, & ! 0 +3,4,2,8,6,7,9,5,1,0, & ! 1 +7,2,9,5,8,6,1,0,4,3, & ! 2 +8,3,6,5,7,9,2,0,1,4, & ! 3 +! -------------------------------- 16 +0,2,5,8,7,4,3,9,6,1, & ! 0 +1,6,0,2,3,5,8,7,4,9, & ! 1 +9,7,6,4,0,1,2,3,8,5, & ! 2 +9,7,6,4,0,1,5,3,8,2, & ! 3 +! -------------------------------- 17 +0,5,2,8,7,3,4,9,1,6, & ! 0 +2,3,1,7,5,6,8,9,0,4, & ! 1 +2,1,7,3,4,9,6,8,5,0, & ! 2 +5,7,0,8,6,1,9,3,4,2, & ! 3 +! -------------------------------- 18 +0,4,7,3,2,8,5,1,9,6, & ! 0 +4,0,3,9,7,8,5,6,2,1, & ! 1 +4,3,0,9,6,1,2,7,5,8, & ! 2 +1,6,0,2,7,5,9,3,4,8, & ! 3 +! -------------------------------- 19 +0,9,6,1,2,5,8,3,4,7, & ! 0 +7,9,5,2,3,0,4,1,8,6, & ! 1 +6,1,8,9,4,3,2,7,5,0, & ! 2 +8,6,5,3,2,7,1,4,0,9, & ! 3 +! -------------------------------- 20 +0,7,3,4,5,2,8,6,1,9, & ! 0 +8,6,5,3,2,0,1,4,7,9, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +5,7,8,0,1,6,2,4,3,9, & ! 3 +! -------------------------------- 21 +0,7,4,3,1,6,9,2,5,8, & ! 0 +2,7,1,3,8,0,5,4,6,9, & ! 1 +2,1,7,3,4,9,6,8,5,0, & ! 2 +3,8,2,4,9,7,6,0,1,5, & ! 3 +! -------------------------------- 22 +0,2,5,8,9,6,1,7,4,3, & ! 0 +1,6,2,0,5,3,8,4,7,9, & ! 1 +2,1,3,7,9,4,0,5,8,6, & ! 2 +5,0,7,8,3,2,4,6,9,1, & ! 3 +! -------------------------------- 23 +0,9,1,6,5,2,8,4,3,7, & ! 0 +7,2,5,9,6,0,1,4,8,3, & ! 1 +9,6,7,4,3,2,1,0,5,8, & ! 2 +3,8,4,2,7,9,5,1,0,6, & ! 3 +! -------------------------------- 24 +0,1,9,6,4,7,3,5,8,2, & ! 0 +7,9,2,5,0,3,4,8,1,6, & ! 1 +3,2,4,8,5,0,1,6,9,7, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 25 +0,2,5,8,7,4,3,9,6,1, & ! 0 +9,7,6,4,0,8,5,3,1,2, & ! 1 +5,7,8,0,4,3,2,1,6,9, & ! 2 +3,4,8,2,1,6,0,7,5,9, & ! 3 +! -------------------------------- 26 +0,8,5,2,3,4,7,1,6,9, & ! 0 +6,8,1,9,7,0,5,4,2,3, & ! 1 +7,5,9,2,1,6,8,3,4,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 27 +0,4,7,3,1,9,6,2,8,5, & ! 0 +4,3,0,9,7,1,2,6,5,8, & ! 1 +4,0,3,9,6,8,5,7,2,1, & ! 2 +9,7,6,4,3,8,2,0,1,5, & ! 3 +! -------------------------------- 28 +0,4,7,3,1,9,6,2,8,5, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +2,7,1,3,4,0,5,8,6,9, & ! 2 +4,0,3,9,6,8,1,7,2,5, & ! 3 +! -------------------------------- 29 +0,3,4,7,8,5,2,9,6,1, & ! 0 +3,8,2,4,0,7,5,9,1,6, & ! 1 +8,5,6,3,4,9,7,2,1,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 30 +0,9,1,6,5,2,8,4,3,7, & ! 0 +9,6,7,4,3,5,8,0,2,1, & ! 1 +7,2,5,9,6,8,3,4,0,1, & ! 2 +9,6,7,4,3,2,8,0,5,1, & ! 3 +! -------------------------------- 31 +0,9,1,6,5,2,8,4,3,7, & ! 0 +3,4,2,8,6,7,9,5,1,0, & ! 1 +7,2,9,5,8,6,1,0,4,3, & ! 2 +8,3,6,5,7,9,2,0,1,4, & ! 3 +! -------------------------------- 32 +0,2,5,8,7,4,3,9,6,1, & ! 0 +5,7,8,0,4,6,9,1,3,2, & ! 1 +9,7,6,4,0,1,2,3,8,5, & ! 2 +9,7,6,4,0,1,5,3,8,2, & ! 3 +! -------------------------------- 33 +0,8,2,5,6,1,9,4,3,7, & ! 0 +2,3,1,7,5,6,8,9,0,4, & ! 1 +1,2,6,0,4,9,7,5,8,3, & ! 2 +5,7,0,8,6,1,9,3,4,2, & ! 3 +! -------------------------------- 34 +0,7,4,3,1,6,9,2,5,8, & ! 0 +4,0,3,9,7,8,5,6,2,1, & ! 1 +4,3,0,9,6,1,2,7,5,8, & ! 2 +9,7,4,6,8,3,5,1,0,2, & ! 3 +! -------------------------------- 35 +0,9,6,1,2,5,8,3,4,7, & ! 0 +7,9,5,2,3,0,4,1,8,6, & ! 1 +6,1,8,9,4,3,2,7,5,0, & ! 2 +8,6,5,3,2,7,1,4,0,9, & ! 3 +! -------------------------------- 36 +0,7,3,4,5,2,8,6,1,9, & ! 0 +8,6,5,3,2,0,1,4,7,9, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +5,7,8,0,1,6,2,4,3,9, & ! 3 +! -------------------------------- 37 +0,4,7,3,2,8,5,1,9,6, & ! 0 +2,7,1,3,8,0,5,4,6,9, & ! 1 +2,1,7,3,4,9,6,8,5,0, & ! 2 +4,9,0,3,2,1,7,8,5,6, & ! 3 +! -------------------------------- 38 +0,4,3,7,9,1,6,8,2,5, & ! 0 +2,7,1,3,8,0,5,4,6,9, & ! 1 +2,1,3,7,9,4,0,5,8,6, & ! 2 +5,0,7,8,3,2,4,6,9,1, & ! 3 +! -------------------------------- 39 +0,5,2,8,9,1,6,7,3,4, & ! 0 +1,0,6,2,7,8,5,3,9,4, & ! 1 +9,6,7,4,3,2,1,0,5,8, & ! 2 +3,8,4,2,7,9,5,1,0,6, & ! 3 +! -------------------------------- 40 +0,2,5,8,7,4,3,9,6,1, & ! 0 +7,9,2,5,0,3,4,8,1,6, & ! 1 +3,2,4,8,5,0,1,6,9,7, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 41 +0,1,9,6,4,7,3,5,8,2, & ! 0 +9,7,6,4,0,8,5,3,1,2, & ! 1 +6,1,9,8,3,4,0,5,7,2, & ! 2 +3,4,8,2,1,6,0,7,5,9, & ! 3 +! -------------------------------- 42 +0,8,5,2,3,4,7,1,6,9, & ! 0 +6,8,1,9,7,0,5,4,2,3, & ! 1 +7,5,9,2,1,6,8,3,4,0, & ! 2 +5,8,7,0,4,9,3,1,2,6, & ! 3 +! -------------------------------- 43 +0,4,7,3,1,9,6,2,8,5, & ! 0 +4,3,0,9,7,1,2,6,5,8, & ! 1 +4,0,3,9,6,8,5,7,2,1, & ! 2 +9,6,7,4,0,5,1,3,2,8, & ! 3 +! -------------------------------- 44 +0,5,8,2,3,7,4,1,9,6, & ! 0 +2,1,3,7,5,4,0,9,8,6, & ! 1 +1,6,2,0,4,3,8,5,7,9, & ! 2 +2,3,7,1,0,5,4,6,9,8, & ! 3 +! -------------------------------- 45 +0,1,6,9,7,4,3,8,5,2, & ! 0 +3,2,8,4,9,5,7,0,6,1, & ! 1 +0,4,5,1,6,8,3,2,7,9, & ! 2 +7,9,5,2,1,0,6,3,8,4, & ! 3 +! -------------------------------- 46 +0,6,1,9,8,2,5,7,3,4, & ! 0 +7,5,2,9,6,3,8,4,1,0, & ! 1 +6,8,1,9,7,2,3,4,0,5, & ! 2 +6,8,9,1,0,4,5,2,7,3, & ! 3 +! -------------------------------- 47 +0,9,1,6,4,3,7,5,2,8, & ! 0 +6,1,9,8,3,7,2,5,4,0, & ! 1 +7,9,2,5,8,3,4,0,1,6, & ! 2 +7,9,2,5,0,1,4,8,3,6, & ! 3 +! -------------------------------- 48 +0,4,7,3,2,8,5,1,9,6, & ! 0 +3,2,4,8,6,0,1,5,9,7, & ! 1 +0,4,1,5,8,6,9,7,2,3, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 49 +0,3,7,4,6,9,1,5,8,2, & ! 0 +8,5,3,6,9,2,7,1,4,0, & ! 1 +0,5,1,4,3,2,7,9,6,8, & ! 2 +3,8,4,2,7,9,5,1,0,6, & ! 3 +! -------------------------------- 50 +0,5,8,2,1,9,6,3,7,4, & ! 0 +7,2,5,9,4,8,3,6,0,1, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +3,4,8,2,1,6,0,7,5,9, & ! 3 +! -------------------------------- 51 +0,2,5,8,7,4,3,9,6,1, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +1,0,2,6,9,7,5,8,3,4, & ! 2 +1,6,0,2,7,5,9,3,4,8, & ! 3 +! -------------------------------- 52 +0,2,8,5,4,7,3,6,9,1, & ! 0 +3,2,8,4,9,5,7,0,6,1, & ! 1 +0,4,5,1,6,8,3,2,7,9, & ! 2 +7,9,5,2,1,0,6,3,8,4, & ! 3 +! -------------------------------- 53 +0,5,8,2,3,7,4,1,9,6, & ! 0 +1,2,0,6,8,4,3,9,5,7, & ! 1 +1,6,2,0,4,3,8,5,7,9, & ! 2 +2,3,7,1,0,5,4,6,9,8, & ! 3 +! -------------------------------- 54 +0,5,2,8,7,3,4,9,1,6, & ! 0 +6,1,9,8,3,7,2,5,4,0, & ! 1 +6,9,1,8,5,0,4,3,2,7, & ! 2 +7,9,2,5,0,1,4,8,3,6, & ! 3 +! -------------------------------- 55 +0,8,2,5,6,1,9,4,3,7, & ! 0 +7,5,2,9,6,3,8,4,1,0, & ! 1 +7,5,2,9,6,1,0,4,3,8, & ! 2 +6,8,9,1,0,4,5,2,7,3, & ! 3 +! -------------------------------- 56 +0,3,4,7,8,5,2,9,6,1, & ! 0 +8,5,3,6,9,2,7,1,4,0, & ! 1 +0,5,1,4,3,2,7,9,6,8, & ! 2 +0,5,4,1,6,9,8,2,3,7, & ! 3 +! -------------------------------- 57 +0,7,4,3,1,6,9,2,5,8, & ! 0 +0,1,4,5,7,3,2,8,9,6, & ! 1 +0,4,1,5,8,6,9,7,2,3, & ! 2 +8,6,3,5,0,4,1,7,2,9, & ! 3 +! -------------------------------- 58 +0,4,7,3,1,9,6,2,8,5, & ! 0 +2,1,7,3,8,9,6,4,5,0, & ! 1 +1,0,2,6,9,7,5,8,3,4, & ! 2 +2,7,3,1,6,8,9,0,4,5, & ! 3 +! -------------------------------- 59 +0,9,6,1,2,5,8,3,4,7, & ! 0 +7,2,5,9,4,8,3,6,0,1, & ! 1 +0,1,5,4,9,7,2,3,8,6, & ! 2 +3,4,8,2,1,6,0,7,5,9/ ! 3 +!====== +data perms/ & +3,2,1,0,4,6,5,7,8,9, & ! 4 +2,3,0,1,6,5,4,7,8,9, & ! 5 +1,0,3,2,5,4,6,7,8,9, & ! 6 +3,2,1,0,4,5,6,7,9,8, & ! 7 +2,3,0,1,4,5,6,9,8,7, & ! 8 +1,0,3,2,4,5,6,8,7,9/ ! 9 +end module jp_pbfil2 +!# diff --git a/src/mgbf/jp_pbfil3.f90 b/src/mgbf/jp_pbfil3.f90 new file mode 100644 index 0000000000..61a6932577 --- /dev/null +++ b/src/mgbf/jp_pbfil3.f90 @@ -0,0 +1,2620 @@ +module jp_pbfil3 +!$$$ module documentation block +! . . . . +! module: jp_pbfil3 +! prgmmr: purser org: NOAA/EMC date: 2021-08 +! +! abstract: Codes for the beta line filters +! +! module history log: +! +! Subroutines Included: +! t22_to_3 - +! t2_to_3 - +! t3_to_22 - +! t33_to_6 - +! t3_to_6 - +! t6_to_33 - +! t44_to_10 - +! t4_to_10 - +! t10_to_44 - +! finmomtab - +! inimomtab - +! tritform - +! tritformi - +! triad - +! gettrilu - +! querytcol - +! hextform - +! hextformi - +! hexad - +! gethexlu - +! queryhcol - +! dectform - +! dectformi - +! decad - +! getdeclu - +! querydcol - +! standardizeb - +! hstform - +! hstformi - +! blinfil - +! dibeta - +! dibetat - +! +! Functions Included: +! +! remarks: +! The routines of this module mostly involve the beta line filters. +! Versions of these routines are provided in 2D, 3D and 4D, based respectively +! on the Triad (3-lines), Hexad (6-lines), and Decad (10-lines) algorithms. +! Some technical explanations are provided in the series of office notes, +! ON498, ON499, ON500. +! +! The style of line filtering is the "Dibeta" combination of two +! nonnegatively-weighted consecutive-imteger-half-span beta filters, whose +! normalization coefficients are stored in the table, "bnorm" and whose +! second moments (spread**2) are stored in the table "bsprds"; these +! moment tables must be initialized in subr. inimomtab before any filtering +! can be done. The max-halp-span size of the table is set by the user, so +! the tables use allocatable space (in module jp_pbfil2); to deallocate this +! storage, the user must invoke fintabmom once all filtering operations +! have been completed. +! +! Aspect tensors in N dimensions are positive-definite and symmetric, and +! therefore require M=(N*(N+1))/2 independent components, which we can arrange +! into a vector of this size. The utility routines tNN_to_M do this; tM_to_NN +! do the opposite. tN_to_M put the outer-product of an N-vector into the +! corresponding M-vector. +! +! The filtering is preceded by a decomposition of the M components of the +! aspect tensor, at each grid point, into M distinct line-second-moments +! and the line-generators they each act along, at every grid point. And +! since, in the general case, the aspect tensor is no longer needed once +! the line filter specifications have been determined, it ic convenient to +! over-write the old aspect tensor components with the new line-second- +! moments ("spread**2"). In other word, we can express the needed action +! as a formal "transform" (and invert it if ever needed, to recover the +! original aspect tensor). The basic decomposition of the aspect tensor +! into its spread**2 components and line generators is done, at a single +! grid point using subroutine triad (2D), hexad (3D), decad (4D). Working +! this into "transform" for a single point, is done in tritform, hextform, +! dectform, and their respective inverse transforms in tritformi, hextfotmi, +! dectformi. In the case of the 3D hexad method, although there are 6 active +! line filters at any given point, each of those lines is associated with +! one of the 7 different "colors" (our term for the nonnull Galois field +! elements) no two of these colors in a given hexad are the same. The +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: spi,sp,dp; use jp_pkind2, only: fpi +use jp_pietc, only: T,F,u0,u1,u3,u4,u5,pi2 +implicit none +private +public:: t22_to_3,t2_to_3,t3_to_22,t33_to_6,t3_to_6,t6_to_33,& + t44_to_10,t4_to_10,t10_to_44, & + finmomtab,inimomtab, & + tritform,tritformi,triad,gettrilu,querytcol, & + hextform,hextformi,hexad,gethexlu,queryhcol, & + dectform,dectformi,decad,getdeclu,querydcol, & + hstform,hstformi,blinfil,dibeta,dibetat +integer(spi),dimension(2,0:2):: i2pair +integer(spi),dimension(2,6) :: i3pair +integer(spi),dimension(2,10) :: i4pair +data i2pair/1,1, 2,2, 1,2/ +data i3pair/1,1, 2,2, 3,3, 2,3, 3,1, 1,2/ +data i4pair/1,1, 2,2, 3,3, 4,4, 1,2, 1,3, 1,4, 3,4, 2,4, 2,3/ + +interface t22_to_3; module procedure i22_to_3, r22_to_3; end interface +interface t2_to_3; module procedure i2_to_3, r2_to_3; end interface +interface t3_to_22; module procedure i3_to_22, r3_to_22; end interface +interface t33_to_6; module procedure i33_to_6, r33_to_6; end interface +interface t3_to_6; module procedure i3_to_6, r3_to_6; end interface +interface t6_to_33; module procedure i6_to_33, r6_to_33; end interface +interface t44_to_10; module procedure i44_to_10,r44_to_10; end interface +interface t4_to_10; module procedure i4_to_10, r4_to_10; end interface +interface t10_to_44; module procedure i10_to_44,r10_to_44; end interface +!--- +interface finmomtab; module procedure finmomtab; end interface +interface inimomtab; module procedure inimomtab; end interface +interface tritform; module procedure tritforms,tritform; end interface +interface tritformi; module procedure tritformi; end interface +interface triad; module procedure triad; end interface +interface gettrilu; module procedure gettrilu; end interface +interface querytcol; module procedure querytcol; end interface +interface hextform; module procedure hextforms,hextform; end interface +interface hextformi; module procedure hextformi; end interface +interface hexad; module procedure hexad; end interface +interface gethexlu; module procedure gethexlu; end interface +interface queryhcol; module procedure queryhcol; end interface +interface dectform; module procedure dectforms,dectform; end interface +interface dectformi; module procedure dectformi; end interface +interface decad; module procedure decad; end interface +interface getdeclu; module procedure getdeclu; end interface +interface querydcol; module procedure querydcol; end interface +!--- +interface standardizeb;module procedure standardizeb; end interface +interface hstform; module procedure hstform; end interface +interface hstformi; module procedure hstformi; end interface +interface blinfil; module procedure blinfil; end interface +interface dibeta + module procedure dibeta1,dibeta2,dibeta3,dibeta4, dibetax3,dibetax4, & + vdibeta1,vdibeta2,vdibeta3,vdibeta4, vdibetax3,vdibetax4 +end interface +interface dibetat + module procedure dibeta1t,dibeta2t,dibeta3t,dibeta4t,dibetax3t, dibetax4t, & + vdibeta1t,vdibeta2t,vdibeta3t,vdibeta4t,vdibetax3t,vdibetax4t +end interface + +contains + +!============================================================================== +subroutine i22_to_3(i22,i3)! [t22_to_3] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(2,2),intent(in ):: i22 +integer(spi),dimension(0:2),intent(out):: i3 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2; i3(L)=i22(i2pair(1,L),i2pair(2,L)); enddo +end subroutine i22_to_3 +!============================================================================== +subroutine r22_to_3(r22,r3)! [t22_to_3] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(2,2),intent(in ):: r22 +real(dp),dimension(0:2),intent(out):: r3 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2; r3(L)=r22(i2pair(1,L),i2pair(2,L)); enddo +end subroutine r22_to_3 + +!============================================================================== +subroutine i2_to_3(i2,i3)! [t2_to_3] +!============================================================================== +use jp_pkind, only: spi +use jp_pmat4, only: outer_product +implicit none +integer(spi),dimension(2),intent(in ):: i2 +integer(spi),dimension(3),intent(out):: i3 +!------------------------------------------------------------------------------ +call t22_to_3(outer_product(i2,i2),i3) +end subroutine i2_to_3 +!============================================================================== +subroutine r2_to_3(r2,r3)! [t2_to_3] +!============================================================================== +use jp_pkind, only: dp +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(2),intent(in ):: r2 +real(dp),dimension(3),intent(out):: r3 +!------------------------------------------------------------------------------ +call t22_to_3(outer_product(r2,r2),r3) +end subroutine r2_to_3 + +!============================================================================== +subroutine i3_to_22(i3,i22)! [t3_to_22] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(0:2),intent(in ):: i3 +integer(spi),dimension(2,2),intent(out):: i22 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2 + i22(i2pair(1,L),i2pair(2,L))=i3(L) + i22(i2pair(2,L),i2pair(1,L))=i3(L) +enddo +end subroutine i3_to_22 +!============================================================================== +subroutine r3_to_22(r3,r22)! [t3_to_22] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(0:2),intent(in ):: r3 +real(dp),dimension(2,2),intent(out):: r22 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=0,2 + r22(i2pair(1,L),i2pair(2,L))=r3(L) + r22(i2pair(2,L),i2pair(1,L))=r3(L) +enddo +end subroutine r3_to_22 + +!============================================================================== +subroutine i33_to_6(i33,i6)! [t33_to_6] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(3,3),intent(in ):: i33 +integer(spi),dimension(6) ,intent(out):: i6 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6; i6(L)=i33(i3pair(1,L),i3pair(2,L)); enddo +end subroutine i33_to_6 +!============================================================================== +subroutine r33_to_6(r33,r6)! [t33_to_6] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(3,3),intent(in ):: r33 +real(dp),dimension(6) ,intent(out):: r6 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6; r6(L)=r33(i3pair(1,L),i3pair(2,L)); enddo +end subroutine r33_to_6 + +!============================================================================== +subroutine i3_to_6(i3,i6)! [t3_to_6] +!============================================================================== +use jp_pkind, only: spi +use jp_pmat4, only: outer_product +implicit none +integer(spi),dimension(3),intent(in ):: i3 +integer(spi),dimension(6),intent(out):: i6 +!------------------------------------------------------------------------------ +call t33_to_6(outer_product(i3,i3),i6) +end subroutine i3_to_6 +!============================================================================== +subroutine r3_to_6(r3,r6)! [t3_to_6] +!============================================================================== +use jp_pkind, only: dp +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(3),intent(in ):: r3 +real(dp),dimension(6),intent(out):: r6 +!------------------------------------------------------------------------------ +call t33_to_6(outer_product(r3,r3),r6) +end subroutine r3_to_6 + +!============================================================================== +subroutine i6_to_33(i6,i33)! [t6_to_33] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(6), intent(in ):: i6 +integer(spi),dimension(3,3),intent(out):: i33 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6 + i33(i3pair(1,L),i3pair(2,L))=i6(L) + i33(i3pair(2,L),i3pair(1,L))=i6(L) +enddo +end subroutine i6_to_33 +!============================================================================== +subroutine r6_to_33(r6,r33)! [t6_to_33] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(6), intent(in ):: r6 +real(dp),dimension(3,3),intent(out):: r33 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,6 + r33(i3pair(1,L),i3pair(2,L))=r6(L) + r33(i3pair(2,L),i3pair(1,L))=r6(L) +enddo +end subroutine r6_to_33 + +!============================================================================== +subroutine i44_to_10(i44,i10)! [t44_to_10] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(4,4),intent(in ):: i44 +integer(spi),dimension(10) ,intent(out):: i10 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10; i10(L)=i44(i4pair(1,L),i4pair(2,L)); enddo +end subroutine i44_to_10 +!============================================================================== +subroutine r44_to_10(r44,r10)! [t44_to_10] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(4,4),intent(in ):: r44 +real(dp),dimension(10) ,intent(out):: r10 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10; r10(L)=r44(i4pair(1,L),i4pair(2,L)); enddo +end subroutine r44_to_10 + +!============================================================================== +subroutine i4_to_10(i4,i10)! [t4_to_10] +!============================================================================== +use jp_pkind, only: spi +use jp_pmat4, only: outer_product +implicit none +integer(spi),dimension(4), intent(in ):: i4 +integer(spi),dimension(10),intent(out):: i10 +!------------------------------------------------------------------------------ +call t44_to_10(outer_product(i4,i4),i10) +end subroutine i4_to_10 +!============================================================================== +subroutine r4_to_10(r4,r10)! [t4_to_10] +!============================================================================== +use jp_pkind, only: dp +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(4), intent(in ):: r4 +real(dp),dimension(10),intent(out):: r10 +!------------------------------------------------------------------------------ +call t44_to_10(outer_product(r4,r4),r10) +end subroutine r4_to_10 + +!============================================================================== +subroutine i10_to_44(i10,i44)! [t10_to_44] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(10), intent(in ):: i10 +integer(spi),dimension(4,4),intent(out):: i44 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10 + i44(i4pair(1,L),i4pair(2,L))=i10(L) + i44(i4pair(2,L),i4pair(1,L))=i10(L) +enddo +end subroutine i10_to_44 +!============================================================================== +subroutine r10_to_44(r10,r44)! [t10_to_44] +!============================================================================== +use jp_pkind, only: spi,dp +implicit none +real(dp),dimension(10), intent(in ):: r10 +real(dp),dimension(4,4),intent(out):: r44 +!------------------------------------------------------------------------------ +integer(spi):: L +!============================================================================== +do L=1,10 + r44(i4pair(1,L),i4pair(2,L))=r10(L) + r44(i4pair(2,L),i4pair(1,L))=r10(L) +enddo +end subroutine r10_to_44 + +!-- + +!================================================================== [finmomtab] +subroutine finmomtab +!============================================================================== +! Finalize the moments table for dibeta filter applications. +! Deallocate the space reserved for moment tables and reset p and nh to their +! zero defaults. +!============================================================================== +use jp_pbfil2, only: p,nh,bnorm,bsprds +implicit none +p=0; nh=0 +if(allocated(bnorm))deallocate(bnorm) +if(allocated(bsprds))deallocate(bsprds) +end subroutine finmomtab + +!================================================================== [inimomtab] +subroutine inimomtab(p_prescribe,nh_prescribe,ff) +!============================================================================== +! Initialize the moments table for dibeta filter applications. +! For the given beta function exponent index, p, and nh half-spans, initialize +! table of the normalizing coefficients, bnorm, and spread**2s, bsprds. +! The calculation involves computing the continuum approximations, m0 and m2, +! to the 0th and 2nd moments, and using the Euler-Maclaurin expansions +! for the correction terms hm0 and hm2 so that the final corrected moments +! cm0 and cm2 for each integer halfwidth up to nh . +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u0,u1,u2 +use jp_pbfil2, only: p,nh,bnorm,bsprds +implicit none +integer(spi),intent(in ):: p_prescribe,nh_prescribe +logical, intent(out):: ff +!------------------------------------------------------------------------------ +integer(spi),parameter :: nk0=2,nk2=nk0+1,np=6,np2p3=np*2+3 +real(dp),dimension(-1:np2p3) :: ffac +real(dp) :: x,xx,m0,m2,hm0,hm2,cm0,cm2 +integer(spi),dimension(0:nk0,np):: n0pk +integer(spi),dimension(0:nk2,np):: n2pk +integer(spi) :: h,i,k,mk0,mk2,p2,p2m1,p2p1,p2p3 +data n0pk/ & + -1, 0, 0, & + -1, 0, 0, & + -5, 14, 0, & + -63, 240, 0, & + -1575, 6930, -2640, & + -68409, 327600, -216216/ +data n2pk/ & + 1, -5, 0, 0, & + 5, -21, 0, 0, & + 63, -285, 126, 0, & + 1575, -7623, 5280, 0, & + 68409, -348075, 306306, -34320, & + 4729725,-24969285, 25552800, -5405400/ +!============================================================================== +call finmomtab ! Table arrays bnorm and bsprds must start off deallocated +ff=(p_prescribe<1 .or. p_prescribe>np) +if(ff)then + print'(" In inimomtab; prescribed exponent p out of bounds")' + return +endif +ff=(nh_prescribe<2 .or. nh_prescribe>1000) +if(ff)then + print'(" In inimomtab; prescribed table size nh out of bounds")' + return +endif +p =p_prescribe +nh=nh_prescribe +allocate(bnorm(nh),bsprds(nh)) +! set up the ffac tables (double-factorial function) +p2=p*2; p2m1=p2-1; p2p1=p2+1; p2p3=p2+3 +ffac(-1)=u1 +ffac(0)=u1 +do i=1,np2p3 + ffac(i)=i*ffac(i-2) +enddo +mk0=(p-1)/2 +mk2=mk0+1 +do h=1,nh + x=h + xx=x*x + m0=u2*ffac(p2)*x/ffac(p2p1) + m2=u2*ffac(p2)*x**3/ffac(p2p3) + hm0=u0 + do k=0,mk0 + hm0=hm0+n0pk(k,p)*xx**k + enddo + hm2=u0 + do k=0,mk2 + hm2=hm2+n2pk(k,p)*xx**k + enddo + cm0=m0+hm0/(ffac(p2p1)*x**p2m1) + cm2=m2+hm2/(ffac(p2p3)*x**p2m1) + bnorm(h)=u1/cm0 + bsprds(h)=cm2/cm0 +enddo +end subroutine inimomtab + +!================================================================== [tritform] +subroutine tritforms(lx,mx, ly,my, aspects, dixs,diys, ff) +!============================================================================= +! Perform direct Triad and hs transforms in a proper subdomain +! domains extents in x, y, are lx:mx, ly:my +! aspects: upon input, these are the 3-vectors of grid-relative aspect tensor +! upon output, these are the 3 active line-filter half-spans. +! dixs: x-component of each of the 6 active line generators +! diys: y-component +! ff: Logical failure flag, output .true. when failure occurs. +! Note that the integer arrays, doxs, diys, are 1-byte integers. +!============================================================================== + +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +integer(spi), intent(in ):: lx,mx,ly,my +real(dp), dimension(3,lx:mx,ly:my),intent(inout):: aspects +integer(fpi),dimension(lx:mx,ly:my,3),intent( out):: dixs,diys +logical, intent( out):: ff +!----------------------------------------------------------------------------- +integer(spi) :: ix,iy +integer(fpi),dimension(2,3):: ltri +!============================================================================= +do iy=ly,my + do ix=lx,mx + call tritform(aspects(:,ix,iy),ltri,ff) + if(ff)then + print'(" Failure in tritform at ix,iy=",2i5)',ix,iy + return + endif + dixs(ix,iy,:)=ltri(1,:) + diys(ix,iy,:)=ltri(2,:) + enddo +enddo +end subroutine tritforms + +!=================================================================== [tritform] +subroutine tritform(aspect ,ltri, ff) +!============================================================================== +! Perform the direct Triad and hs transform. +! Take a 3-vector representation of the aspect tensor and +! transform it to the vector of half-spans for the beta line filter +! and 1-byte-integer line generators. +! aspect: input as aspect tensor components, output as spread**2 +! ltri : three active line generators in ascending color order +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +real(dp),dimension(3), intent(inout):: aspect +integer(fpi),dimension(2,3),intent( out):: ltri +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp), dimension( 3):: wtri +integer(fpi),dimension(2,3):: ltri3 +integer(spi) :: i +!============================================================================== +call triad(aspect, ltri3,wtri,ff) +if(ff)then + print'(" In tritform; triad failed; check aspect tensor")' + return +endif +ltri=ltri3 +aspect=wtri +do i=1,3 + call hstform(aspect(i),ff) + if(ff)then + print'(" In tritform; hstform failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif +enddo +end subroutine tritform + +!================================================================== [tritformi] +subroutine tritformi(aspect ,ltri, ff) +!============================================================================== +! Perform the inverse hs and triad transform. +! Take a 3-vector of the active spreads**2, +! and their line generators, and return the implied +! aspect tensor in the same 3-vector that contained the half-spans +! aspect: input as half-spans; output as aspect tensor components +! ltri : corresponding successive line generators (using 1-byte integers) +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp),dimension(3),intent(inout) :: aspect +integer(fpi),dimension(2,3),intent(in ):: ltri +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp),dimension(2,2):: a22 +real(dp),dimension(2) :: vec +integer(spi) :: i +!============================================================================== +a22=u0 +do i=1,3 + vec=ltri(:,i) + call hstformi(aspect(i),ff) + if(ff)then + print'(" In tritformi; hstformi failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif + a22=a22+outer_product(vec,vec)*aspect(i) +enddo +call t22_to_3(a22,aspect) +end subroutine tritformi + +!===================================================================== [triad] +subroutine triad(aspect,ltri,wtri,ff) +!============================================================================= +! A version of the Triad iterative algorithm for resolving a given aspect +! tensor, A, rearranged as the 3-vector, +! Aspect = (/A_11, A_22, A_12/) +! onto a bisis of generator directions, the integer 2-vectors ltri, together +! with their corresponding aspect projections, or "weights", wtri. +! +! Aspect: The given aspect tensor in the form of a 3-vector (see above) +! Ltri: The three integer 2-vectors whose members define a triad +! and whose outer-products imply basis 3-vectors into which the aspect +! is resolved. This matrix of 3-vectors is denoted Lu, but only its +! inverse, Lui, is needed in this routine. +! wtri: Real nonnegative weights (projected aspect) corresponding to ltri. +! ff : Failure flag, raised on output only when iterations exceed limit. +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension(3), intent(in ):: aspect +integer(fpi),dimension(2,0:2),intent(out):: ltri +real(dp), dimension(0:2) ,intent(out):: wtri +logical, intent(out):: ff +!----------------------------------------------------------------------------- +integer(spi),parameter :: nit=200 +real(dp), parameter :: bcmins=-1.e-14_dp +real(dp), dimension(3,0:2):: rlui +real(dp) :: dwtri +integer(spi),dimension(-2:2) :: ssigns +integer(spi),dimension(0:2) :: signs +integer(fpi),dimension(2,0:2):: defltri ! <- default Ltri +integer(spi),dimension(3,0:2):: deflui ! <- default Lui +integer(spi),dimension(3,0:2):: lui +integer(spi),dimension(3) :: dlui +integer(spi),dimension(1) :: ii +integer(spi) :: it,kcol,lcol,mcol +data ssigns/1,1,-1,1,1/ +data deflui/1, 0,-1, 0, 1,-1, 0, 0, 1/ +data defltri/ 1, 0, 0,1, -1,-1/ +!============================================================================== +ltri=defltri; lui=deflui +rlui=lui; wtri=matmul(aspect,rlui) +do it=1,nit + ii=minloc(wtri)-1; kcol=ii(1); dwtri=wtri(kcol)*2; if(dwtri>=bcmins)exit + lcol=mod(kcol+1,3); mcol=mod(lcol+1,3); dlui=lui(:,kcol)*2 + Ltri(:,lcol)=-Ltri(:,Lcol); Ltri(:,kcol)=-Ltri(:,Lcol)-Ltri(:,mcol) + signs=ssigns(-kcol:2-kcol) + lui=lui+outer_product(dlui,signs) + wtri=wtri+signs*dwtri +enddo +ff=it>nit +end subroutine triad + +!=================================================================== [gettrilu] +subroutine gettrilu(ltri,lu) +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(fpi),dimension(2,0:2),intent(in ):: ltri +integer(fpi),dimension(2,0:2),intent(out):: lu +!----------------------------------------------------------------------------- +integer(spi):: i,L +!============================================================================== +do i=0,2; do L=1,2; lu(L,i)=Ltri(i2pair(1,L),i)*Ltri(i2pair(2,L),i);enddo;enddo +end subroutine gettrilu + +!============================================================================== +subroutine querytcol(vin,tcol)! [querytcol] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(2),intent(in ):: vin +integer(spi), intent(out):: tcol +!------------------------------------------------------------------------------ +integer(spi),dimension(3):: tcols +integer(spi) :: i +data tcols/0,1,2/ +!============================================================================== +i=modulo(vin(1),2)+2*modulo(vin(2),2) +if(i==0)stop 'In querytcol; invalid 2-vector vin has all components even' +tcol=tcols(i) +end subroutine querytcol + +!=================================================================== [hextform] +subroutine hextforms(lx,mx,ly,my,lz,mz, aspects, qcols,dixs,diys,dizs, ff) +!============================================================================== +! Perform direct hexad and hs transforms in a proper subdomain +! domains extents in x, y, z, are lx:mx, ly:my, lz:mz +! aspects: upon input, these are the 6-vectors of grid-relative aspect tensor +! upon output, these are the six active-line-filter half-spans. +! qcols: outout as the Galois "colors" of each successive line-filter, listed +! in ascending order but with zeros at positions 0 and 7 of each list. +! dixs: x-component of each of the 6 active line generators +! diys: y-component +! dizs: z-component +! ff: Logical failure flag, output .true. when failure occurs. +! Note that the integer arrays, qcols, doxs, diys, dizs, are 1-byte integers. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +integer(spi), intent(in ):: lx,mx, & + ly,my, & + lz,mz +real(dp), dimension( 6,lx:mx,ly:my,lz:mz),intent(inout):: aspects +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent( out):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent( out):: dixs,diys,dizs +logical, intent( out):: ff +!------------------------------------------------------------------------------ +integer(spi) :: ix,iy,iz +integer(fpi),dimension(3,6):: lhex +!============================================================================== +do iz=lz,mz + do iy=ly,my + do ix=lx,mx + call hextform(aspects(:,ix,iy,iz),qcols(:,ix,iy,iz),& + lhex,ff) + if(ff)then + print'(" Failure in hextform at ix,iy,iz=",3i5)',ix,iy,iz + return + endif + dixs(ix,iy,iz,:)=lhex(1,:) + diys(ix,iy,iz,:)=lhex(2,:) + dizs(ix,iy,iz,:)=lhex(3,:) + enddo + enddo +enddo +end subroutine hextforms + +!=================================================================== [hextform] +subroutine hextform(aspect, qcol,lhex, ff) +!============================================================================== +! Perform the direct Hexad and hs transform. +! Take a 6-vector representation of the aspect tensor and +! transform it to the vector of half-spans for the dibeta filter, +! and 1-byte-integer line generators, and color list. +! aspect: input as aspect tensor components, output as half-spans +! qcol : output as colors of successive active lines, but with +! "spare" null elements 0 and 7. +! lhex : six active line generators in ascending color order +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +real(dp),dimension(6), intent(inout):: aspect +integer(fpi),dimension(0:7),intent( out):: qcol +integer(fpi),dimension(3,6),intent( out):: lhex +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp), dimension( 7):: whex7 +integer(fpi),dimension(3,7):: lhex7 +integer(fpi) :: i,j +!============================================================================== +call hexad(aspect, lhex7,whex7,ff) +if(ff)then + print'(" In hextform; hexad, failed; check aspect tensor")' + return +endif +qcol(0)=0; qcol(7)=0 +j=1 +do i=1,7 + if(sum(abs(lhex7(:,i)))==0)cycle + qcol(j)=i + lhex(:,j)=lhex7(:,i) + aspect(j)=whex7( i) + j=j+1_fpi +enddo +do i=1,6 + call hstform(aspect(i),ff) + if(ff)then + print'(" In hextform; hstform failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif +enddo +ff=(j/=7) +if(ff)print'(" In hextform; inconsistent hexad generator set found")' +end subroutine hextform + +!================================================================== [hextformi] +subroutine hextformi(aspect, qcol,lhex, ff) +!============================================================================== +! Perform the inverse hs and hexad transform. +! Take a 6-vector of the active half-spans, their respective +! colors, and their line generators, and return the implied +! aspect tensor in the same 6-vector that contained the spreads**2 +! aspect: input as spreads**2; output as aspect tensor components +! qcol : colors of successive active hexad members (using 1-byte integers) +! lhex : corresponding successive line generators (using 1-byte integers) +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension( 6),intent(inout):: aspect +integer(fpi),dimension(0:7),intent(in ):: qcol +integer(fpi),dimension(3,6),intent(in ):: lhex +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp),dimension(3,3):: a33 +real(dp),dimension(3) :: vec +integer(fpi) :: i,j +!============================================================================== +a33=u0 +j=1 +do i=1,7 + if(qcol(j)/=i)cycle + call hstformi(aspect(j),ff) + if(ff)then + print'(" In hextformi; hstformi failed at i,j=",2i2)',i,j + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif + vec=lhex(:,j) + a33=a33+outer_product(vec,vec)*aspect(j) + j=j+1_fpi +enddo +ff=(j/=7) +if(ff)print'(" In hextformi; Inconsistent qcol")' +call t33_to_6(a33,aspect) +end subroutine hextformi + +!====================================================================== [hexad] +subroutine hexad(aspect,lhex7,whex7,ff) +!============================================================================== +! A version of the Hexad iterative algorithm for resolving a given aspect +! tensor, A, rearranged as the 6-vector, +! Aspect= (/ A_11, A_22, A_33, A_23, A_31, A_12 /) +! onto a basis of generator directions, the integer 3-vectors lhex7, together +! with their corresponding aspect projections, or "weights", whex7. +! Although seven lhex vectors and weights are given (arranged by "colors" 0--6) +! only six of these -- those that do NOT equal the "color" of the hexad +! itself --- are nonzero (and are positive when the hexad is correctly +! resolving the target aspect tensor, Aspect). The style of this algorithm +! is as close as possible to the the description in documentation "Note 7". +! +! Aspect: the given aspect tensor in the form of a 6-vector (see above). +! Lhex7: The seven integer 3-vectors whose 6 non-null members define a Hexad +! and whose outer-products imply basis 6-vectors into which the aspect +! is resolved. This matrix of 6-vectors is denoted Lu, but only its +! inverse, Lui, is needed in this routine. These seven 3-vectors are +! arranged in decreasing order of "cardinality", +! meaning that the cardinal +! directions' colors define the first three vectors, the next three have +! two odd components, and the seventh has all odd components. +! whex7: Seven real nonnegative weights (projected aspect) +! corresponding to lhex +! (zero value in the case of the null vector of lhex7) +! ff : failure flag, raised only when the iterations exceed their limit. +! The algorithm here benefits from using the symmetry of the Fano plane +! and related GF(8) nonnull elements which, arranged cyclically, imply that +! the Jth "line" comprises points j+line(0), j+line(1), j+line(2), where +! Line = (/ 1, 2, 4/) and j is taken modulo 7. +! Note: the "K-set" of 3 members of the Lhex (indexed hcol+6, hcol+5, hcol+3) +! or equivalently, hcol-line(0),hcol-line(1),hclo-line(2), +! where arithmetic is modulo-7, are sufficient to form a "basis" from which +! the other ("L-set") nonnull members of Lhex are implied. To make the +! iterations efficient, we can iterate just this K-set, because the changes +! made to the effective projection operator, Lui, are, by the Woodbury +! formula, of rank-1 at each iteration, and the whex components change by +! a corresponding pattern of increments that do not need us to find the full +! set of Lhex, nor the explicit Lu, each iteration. +! Note that some integer arrays use 1-byte integer type to save space. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension(6), intent(in ):: aspect +integer(fpi),dimension(3,7), intent(out):: lhex7 +real(dp), dimension(7), intent(out):: whex7 +logical, intent(out):: ff +!------------------------------------------------------------------------------ +integer(spi),parameter :: nit=200 +real(dp), parameter :: bcmins=-1.e-14_dp +real(dp), dimension(6,0:6) :: rlui +real(dp), dimension(0:6) :: whex +real(dp) :: dwhex +integer(spi),dimension(0:6) :: signs +integer(fpi),dimension(3,0:6) :: deflhex +integer(spi),dimension(6,0:6) :: deflui +integer(spi),dimension(-6:6) :: sstriad +integer(spi),dimension(6) :: dlui,ttriad +integer(fpi),dimension(3,0:2) :: Kset +integer(fpi),dimension(3,3,6) :: mmats +integer(spi),dimension(0:2) :: Line +integer(spi),dimension(1) :: ii +integer(fpi),dimension(3,0:6) :: lhex +integer(spi),dimension(6,0:6) :: lui +integer(spi),dimension(0:6) :: jcol +integer(spi) :: hcol +integer(spi) :: i,ip,it,j,kcol,dcol,L +data deflhex/0,0,0, 1,-1,0, 0,1,-1, 0,0,1, -1,0,1, 0,1,0, 1,0,0/ +data deflui/ 6*0, 0, 0, 0, 0, 0,-1, 0, 0, 0,-1, 0, 0, 0, 0, 1, 1, 1, 0, & + 0, 0, 0, 0,-1, 0, 0, 1, 0, 1, 0, 1, 1, 0, 0, 0, 1, 1/ +data Mmats/1, 1,-1, 1, 0, 0, 1, 0,-1, -1, 1, 0, -1, 1, 1, 0, 1, 0, & + 0,-1, 1, 1,-1, 0, 1, 0, 0, 0, 0, 1, 0,-1, 1, 1,-1, 1, & + -1, 0, 1, 0, 0, 1, -1, 1, 0, 0, 1, 0, 1, 0,-1, 0, 1,-1/ +data ttriad/5,3,3,6,5,6/ +data sstriad/-1,-1, 1,-1, 1, 1, 1,-1,-1, 1,-1, 1, 1/ +data Line/1,2,4/ +data jcol/7,4,6,3,5,2,1/ +!============================================================================== +lhex=deflhex; lui=deflui; hcol=0 +rlui=lui; whex=matmul(aspect,rlui) +do i=0,2; Kset(:,i)=Lhex(:,modulo(hcol-line(i),7)); enddo +do it=1,nit + ii=minloc(whex)-1; kcol=ii(1); dwhex=whex(kcol); if(dwhex>=bcmins)exit + dcol=modulo(kcol-hcol,7); hcol=kcol; L=modulo(hcol+ttriad(dcol),7) + Kset=matmul(Kset,Mmats(:,:,dcol)) + dlui=lui(:,hcol) + signs=sstriad(-L:6-L) + lui =lui+outer_product(dlui,signs) + whex=whex+signs*dwhex +enddo +ff=it>nit; if(ff)return +do i=0,2; ip=modulo(i+1,3) + lhex(:,modulo(hcol-line(i),7))=Kset(:,i) + lhex(:,modulo(hcol+line(i),7))=Kset(:,i)-Kset(:,ip) +enddo +lhex(:,kcol)=0 +lhex7=0 +whex7=u0 +do i=0,6 + j=jcol(i) + lhex7(:,j)=lhex(:,i) + whex7( j)=whex( i) +enddo + +end subroutine hexad + +!=================================================================== [gethexlu] +subroutine gethexlu(lhex,lu) +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(fpi),dimension(3,0:6),intent(in ):: lhex +integer(fpi),dimension(6,0:6),intent(out):: lu +!------------------------------------------------------------------------------ +integer(spi):: i,L +!============================================================================== +do i=0,6; do L=1,6; lu(L,i)=Lhex(i3pair(1,L),i)*Lhex(i3pair(2,L),i);enddo;enddo +end subroutine gethexlu + +!============================================================================== +subroutine queryhcol(vin,hcol)! [queryhcol] +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(3),intent(in ):: vin +integer(spi), intent(out):: hcol +!------------------------------------------------------------------------------ +integer(spi),dimension(7):: hcols +integer(spi) :: i +data hcols/6,5,1,3,4,2,0/ +!============================================================================== +i=modulo(vin(1),2)+2*modulo(vin(2),2)+4*modulo(vin(3),2) +if(i==0)stop 'In queryhcol; invalid 3-vector Vin has all components even' +hcol=hcols(i) +end subroutine queryhcol + +!=================================================================== [dectform] +subroutine dectforms(lx,mx,ly,my,lz,mz,lw,mw,aspects,qcols, & + dixs,diys,dizs,diws, ff) +!============================================================================== +! Perform direct Decad and ha transforms in a proper subdomain +! domains extents in x, y, z, w, are lx:mx, ly:my, lz:mz, lw:mw +! aspects: upon input, these are the 10-vectors of grid-relative aspect tensor +! upon output, these are the ten active-line-filter half-spans. +! qcols: outout as the Galois "colors" of each successive line-filter, listed +! in ascending order, with zeros at positions 0 and 11 of each list. +! dixs: x-component of each of the 6 active line generators +! diys: y-component +! dizs: z-component +! diws: w-component +! ff: Logical failure flag, output .true. when failure occurs. +! Note that the integer arrays, qcols, doxs, diys, dizs, diws, +! are 1-byte integers. +! +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +integer(spi), intent(in ):: lx,mx,& + ly,my,& + lz,mz,& + lw,mw +real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: aspects +integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),intent( out):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10), intent( out):: dixs,& + diys,& + dizs,& + diws +logical, intent( out):: ff +!------------------------------------------------------------------------------ +integer(spi) :: ix,iy,iz,iw +integer(fpi),dimension(4,10):: ldec +!============================================================================== +do iw=lw,mw + do iz=lz,mz + do iy=ly,my + do ix=lx,mx + call dectform(aspects(:,ix,iy,iz,iw),qcols(0:11,ix,iy,iz,iw),& + ldec,ff) + if(ff)then + print'(" Failure in dectform at ix,iy,iz,iw=",4i5)',& + ix,iy,iz,iw + return + endif + dixs(ix,iy,iz,iw,:)=ldec(1,:) + diys(ix,iy,iz,iw,:)=ldec(2,:) + dizs(ix,iy,iz,iw,:)=ldec(3,:) + diws(ix,iy,iz,iw,:)=ldec(4,:) + enddo + enddo + enddo +enddo +end subroutine dectforms + +!=================================================================== [dectform] +subroutine dectform(aspect, qcol,ldec, ff) +!============================================================================== +! Perform the direct Decad and hs transform. +! Take a 10-vector representation of the aspect tensor and +! transform it to the vector of half-spans +! and 1-byte-integer line generators, and color list. +! aspect: input as aspect tensor components, output as spread**2 +! qcol : output as colors of successive active lines, but with +! "spare" null elements 0 and 11. +! ldec : ten active line generators in ascending color order +! ff : logical failure flag. +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +implicit none +real(dp),dimension(10), intent(inout):: aspect +integer(fpi),dimension(0:11),intent( out):: qcol +integer(fpi),dimension(4,10),intent( out):: ldec +logical, intent( out):: ff +!----------------------------------------------------------------------------- +real(dp), dimension( 15):: wdec15 +integer(fpi),dimension(4,15):: ldec15 +integer(fpi) :: i,j +!============================================================================= +call decad(aspect, ldec15,wdec15,ff) +if(ff)then + print'(" In dectform; decad, failed; check aspect tensor")' + return +endif +qcol(0)=0; qcol(11)=0 +j=1 +do i=1,15 + if(sum(abs(ldec15(:,i)))==0)cycle + qcol(j)=i + ldec(:,j)=ldec15(:,i) + aspect(j)=wdec15( i) + j=j+1_fpi +enddo +do i=1,10 + call hstform(aspect(i),ff) + if(ff)then + print'(" In dectform; hstform failed at i=",i2)',i + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif +enddo + +ff=(j/=11) +if(ff)print'(" In dectform; inconsistent decad generator set found")' +end subroutine dectform + +!================================================================= [dectformi] +subroutine dectformi(aspect, qcol,ldec, ff) +!============================================================================= +! Perform the inverse hs and decad transform. +! Take a 10-vector of the active half-spans, their respective +! colors, and their line generators, and return the implied +! aspect tensor in the same 10-vector that contained the spreads**2 +! aspect: input as spreads**2; output as aspect tensor components +! qcol : colors of successive active decad members (using 1-byte integers) +! ldec : corresponding successive line generators (using 1-byte integers) +! ff : logical failure flag. +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pmat4, only: outer_product +implicit none +real(dp), dimension( 10),intent(inout):: aspect +integer(fpi),dimension(0:11),intent(in ):: qcol +integer(fpi),dimension(4,10),intent(in ):: ldec +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp),dimension(4,4):: a44 +real(dp),dimension(4) :: vec +integer(spi) :: i,j +!============================================================================== +a44=u0 +j=1 +do i=1,15 + if(qcol(j)/=i)cycle + call hstformi(aspect(j),ff) + if(ff)then + print'(" In dectformi; hstformi failed at i,j=",2i3)',i,j + print'(" Check that inimomtab has been called to initialize exponent")' + print'(" p, table size, nh, and the moment tables for line filters")' + return + endif + vec=ldec(:,j) + a44=a44+outer_product(vec,vec)*aspect(j) + j=j+1 +enddo +ff=(j/=11) +if(ff)then + print'(" In dectformi; Inconsistent qcol")' + return +endif +call t44_to_10(a44,aspect) +end subroutine dectformi + +!====================================================================== [decad] +subroutine decad(aspect,ldec15,wdec15,ff) +!============================================================================== +! This version is derived from $HOMES/on500/decadf.f90 +! In this version ALWAYS start from the default decad +! Also, rearrange the 10 active line directions and weights +! into arrays of 15, ordered according the colors of the fundamental +! 3*3*3*3 cube's surface generators' degrees of "cardinality". By this +! we mean that the colors of (1,0,0,0), (0,1,0,0), (0,0,1,0), (0,0,0,1) +! come first, followed by the colors of (1,1,0,0), (1,0,1,0), (1,0,0,1), +! (0,1,1,0), (0,1,0,1), (0,0,1,1), followed by the colors of (1,1,1,0), +! (1,1,0,1), (1,0,1,1), (0,1,1,1), and followed finally by the color +! of the "least cardinal" (or "most diagonal") type of element, (1,1,1,1). +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +use jp_pbfil2,only: dec0,dodec0t,umat10,umat12,umats,nei,dcol10,dcol12,& + nei0a,jcora,nei0b,jcorb,nei17,nei22,nei33,nei38, tcors,& + kcor10a5,kcor10b1,kcor10b2,kcor12b0, & + kcor17c0,kcor22c0,kcor33c0,kcor38c0,kcor44c0,kcor51c0,kcor53c0,kcor58c0,& + twt10a5,twt10b1,twt10b2,twt12c0,qwt10a,qwt10b,qwt10c,qwt10d,qwt10e, & + qwt12a,qwt12b0,tperms,perm10,perm12,perms +use jp_pmat, only: inv +use jp_pmat4, only: outer_product,det +implicit none +real(dp),dimension(10), intent(in ):: aspect +integer(fpi),dimension(4,15),intent(out):: ldec15 +real(dp), dimension( 15),intent(out):: wdec15 +logical, intent(out):: ff +!------------------------------------------------------------------------------ +integer(spi), parameter :: nit=40 +real(dp),parameter :: bcmins=-1.e-14_dp +real(dp),dimension(10,0:9) :: rlui +real(dp),dimension(0:9) :: awdec,xwdec,newwdec,wdec +real(dp) :: dwdec +integer(spi) :: ktyp,dcol ! Redundant? +integer(spi),dimension(0:9) :: palet ! +integer(spi),dimension(4,0:9) :: eldec ! +integer(spi),dimension(10,0:9) :: lu,lui +integer(fpi),dimension(4,0:9) :: defeldec +integer(spi),dimension(4,0:9) :: neweldec +integer(spi),dimension(0:9) :: defpalet +integer(spi),dimension(1) :: ii +integer(spi),dimension(4,4) :: tcor +integer(spi) :: i,it,j,k,newktyp,newdcol,abscol,& + jcol,kcor,jcor +integer(spi),dimension(4,0:3) :: newbase +integer(spi),dimension(0:9) :: perm,qwt,tperm +integer(spi),dimension(0:14) :: icol15 +data icol15/1,2,3,4,5,8,10,12,6,9,11,14,15,13,7/ +data defeldec/ & + 0, 0, 1, 0, 0,-1, 0, 0, 1, 0, 0, 0, -1, 0,-1,-1, 0, 1, 0, 1, & + 0, 0, 0,-1, -1, 0,-1, 0, 1, 1, 1, 1, -1,-1, 0,-1, 1, 0, 0, 1/ +data defpalet/ 2, 1, 0,13, 9, 3, 8,12, 7,14/ +!============================================================================== +eldec=defeldec; palet=defpalet; ktyp=4; dcol=4 +do j=0,9; call t4_to_10(eldec(:,j),lu(:,j)); enddo +lui=transpose(lu) +call inv(lui,ff) +if(ff)then + print'(" In decad, at A; lu cannot be inverted")' + return +endif +rlui=lui +wdec=matmul(aspect,rlui) +do it=1,nit + ii=minloc(wdec)-1; k=ii(1); dwdec=wdec(k); + if(dwdec>=bcmins)exit +!-- The following is translated from the "x" block of old tdecadf: + newktyp=nei(k,ktyp) + if(ktyp<12)then + abscol=modulo(dcol+dcol10(k,ktyp),15)! Anticipated uncorrected abs col + newbase(:,:)=matmul(eldec(:,0:3),umat10(:,:,k,ktyp)) + else + if(k<4)then + abscol=modulo(dcol+dcol12(k,ktyp),15) + newbase(:,:)=matmul(eldec(:,0:3),umat12(:,:,k,ktyp))/2 + else + abscol=dcol + newbase(:,:)=matmul(eldec(:,0:3),umats(:,:,k))/2 + endif + endif + jcol=0 + jcor=0 + if(newktyp==11)then + jcol=abscol/3 + if(jcol>0)then + jcor=6+jcol + endif + abscol=modulo(abscol,3) + elseif(newktyp>=44)then + jcol=abscol/5 + if(jcol>0)then + select case(ktyp) + case(0:3) + newktyp=nei0a(jcol,ktyp) + jcor=jcora(jcol,ktyp) + case(4:9) + newktyp=nei0b(jcol,k,ktyp) + jcor=jcorb(jcol,k,ktyp) + case(17); newktyp=nei17(jcol); jcor=10+jcol + case(22); newktyp=nei22(jcol); jcor=10+jcol + case(33); newktyp=nei33(jcol); jcor=10+jcol + case(38); newktyp=nei38(jcol); jcor=10+jcol + case(44); jcor=10+jcol + case(51); jcor=10+jcol + case(53); jcor=10+jcol + case(58); jcor=10+jcol + case default + print'(" In decad. Unrecognized ktyp=",i10)',ktyp + ff=.true. + return + end select + endif + abscol=modulo(abscol,5) + if(ktyp<12)then + newdcol=modulo(abscol-dcol10(k,ktyp),15) + else + if(k<4)then + newdcol=modulo(abscol-dcol12(k,ktyp),15) + else + newdcol=dcol + endif + endif + endif + if(jcor /= 0)then + tcor=tcors(:,:,jcor) + newbase=matmul(newbase(:,:),tcor)/2 + endif + + if(ktyp<12)then + perm=perm10(:,k,ktyp) + select case(ktyp) + case(0:3) + if(k==5)then + kcor=kcor10a5(jcol,ktyp) + qwt=twt10a5(:,kcor) + else + qwt=qwt10a(:,k) + endif + case(4:7) + if(k==1)then + kcor=kcor10b1(jcol,ktyp) + qwt=twt10b1(:,kcor) + elseif(k==2)then + kcor=kcor10b2(jcol,ktyp) + qwt=twt10b2(:,kcor) + else + qwt=qwt10b(:,k) + endif + case(8:9) + if(k==1)then + kcor=kcor10b1(jcol,ktyp) + qwt=twt10b1(:,kcor) + elseif(k==2)then + kcor=kcor10b2(jcol,ktyp) + qwt=twt10b2(:,kcor) + else + qwt=qwt10c(:,k) + endif + case(10) + qwt=qwt10d(:,k) + case(11) + qwt=qwt10e(:,k) + end select + else + if(k==0)then + perm=perm12(:,k,ktyp) + kcor=kcor12b0(ktyp) + select case(ktyp) + case(17); kcor=kcor17c0(jcol); qwt=twt12c0(:,kcor) + case(22); kcor=kcor22c0(jcol); qwt=twt12c0(:,kcor) + case(33); kcor=kcor33c0(jcol); qwt=twt12c0(:,kcor) + case(38); kcor=kcor38c0(jcol); qwt=twt12c0(:,kcor) + case(44); kcor=kcor44c0(jcol); qwt=twt12c0(:,kcor) + case(51); kcor=kcor51c0(jcol); qwt=twt12c0(:,kcor) + case(53); kcor=kcor53c0(jcol); qwt=twt12c0(:,kcor) + case(58); kcor=kcor58c0(jcol); qwt=twt12c0(:,kcor) + case default + qwt=qwt12b0(:,kcor) + end select + elseif(k<4)then + perm=perm12(:,k,ktyp) + qwt=qwt12a(:,k) + else + perm=perms(:,k) + qwt=qwt12a(:,k) + endif + endif + if(jcor/=0)then + do i=0,9 + tperm(i)=tperms(perm(i),jcor) + enddo + perm=tperm + endif + call standardizeb(newbase(:,:),FF) + if(FF)then + print'(" In decad, at B; failure of subr. standardizedb")' + return + endif + +!-------- + awdec=wdec-qwt*dwdec + do i=0,9 + newwdec(perm(i))=awdec(i) + enddo + if(newktyp<12)then + neweldec=matmul(newbase,dec0) + else + neweldec=matmul(newbase,dodec0t)/2 + endif + do j=0,9 + call t4_to_10(neweldec(:,j),lu(:,j)) + enddo + lui=transpose(lu) + call inv(lui,ff) + if(ff)then + print'(" In decad, at C; lu cannot be inverted")' + return + endif + rlui=lui + xwdec=matmul(aspect,rlui) +! if(maxval(abs(xwdec-newwdec))>.001)read(*,*) + eldec=neweldec + ktyp=newktyp + dcol=abscol + wdec=xwdec +enddo +if(it>nit)then + ff=.true. + print '(" in decad, at D; failure of decad iterations to converge")' + return +endif +do j=0,9 + call querydcol(eldec(:,j),palet(j)) +enddo +print'(" departing decad having used it = ",i5," iterations.")',it +! Insert the decad into its proper color slots in order of decreasing +! "cardinality:" +wdec15=u0 +ldec15=0 +do i=0,9 + j=icol15(palet(i)) +! ldec15(:,j)=int(eldec(:,i),kind(fpi)) + ldec15(:,j)=int(eldec(:,i),fpi) + wdec15( j)= wdec( i) +enddo +end subroutine decad + +!=================================================================== [getdeclu] +subroutine getdeclu(ldec,lu) +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(spi),dimension( 4,0:14),intent(in ):: ldec +integer(spi),dimension(10,0:14),intent(out):: lu +!------------------------------------------------------------------------------ +integer(spi):: i,L +!============================================================================== +do i=0,14;do L=1,10;lu(L,i)=Ldec(i4pair(1,L),i)*Ldec(i4pair(2,L),i);enddo;enddo +end subroutine getdeclu + +!============================================================================== +subroutine querydcol(vin,dcol)! [querydcol] +!============================================================================== +use jp_pkind, only: spi; use jp_pkind2, only: fpi +implicit none +integer(spi),dimension(4),intent(in ):: vin +integer(spi), intent(out):: dcol +!------------------------------------------------------------------------------ +integer(spi),dimension(15):: dcols +integer(spi),dimension(4) :: bbbb +integer(spi) :: i +data dcols/ 0, 1, 4, 2, 8, 5,10, 3,14, 9, 7, 6,13,11,12/ +data bbbb/1,2,4,8/ +!============================================================================== +i=dot_product(bbbb,modulo(vin,2)) +if(i==0)stop 'In querydcol; invalid 4-vector Vin has all components even' +dcol=dcols(i) +end subroutine querydcol + +!=============================================================== [standardizeb] +subroutine standardizeb(bases,FF) +!============================================================================== +! Standardize 4*4 bases vectors by making sure the first nonzero component +! of the first column is positive in the standardized version. +! If the first column is null, raise the (logical) failure flag, FF. +!============================================================================== +use jp_pkind, only: spi +implicit none +integer(spi),dimension(4,4),intent(inout):: bases +logical, intent( out):: FF +integer(spi) :: i,b +!============================================================================== +FF=.false. +do i=1,4 + b=bases(i,1) + if(b==0)cycle + if(b<0)bases=-bases + return +enddo +print'(" WARNING! In subroutine standardizeb, first column is null:")' +FF=.true. +end subroutine standardizeb + +!==================================================================== [hstform] +subroutine hstform(hs,ff)! +!============================================================================== +! Perform the "hspan transform". For a given spread**2, replace it with the +! corresponding effective half-span corresponding to beta filters of the +! already-initialized exponent p. Generally, hs>=1, lies between consecutive +! integers, h, h+1 <=nh (nh is also already given in jp_pbfil2.mod). The linear +! interpolation weights at h and h+1 for this target, applied to the +! "interpolation" of the two standardized p-exponent beta distributions of +! half-spans h and h+1 will also be standardized (sum of gridded responses = 1) +! and will possess exactly the prescribed spread**2, the input hs. +! This transform is obviously invertible (see subr. hstformi). +! But if the given hs does not fit within the range of the +! table, bsprds, return a raised failure flag, ff. +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u0 +use jp_pbfil2,only: nh,bsprds +implicit none +real(dp),intent(inout):: hs +logical, intent( out):: ff +!------------------------------------------------------------------------------ +integer(spi):: h +!============================================================================== +ff=hs= hs)then + hs=h-(bsprds(h)-hs)/(bsprds(h)-bsprds(h-1)) + return + endif +enddo +ff=.true. +end subroutine hstform + +!=================================================================== [hstformi] +subroutine hstformi(hs,ff) +!============================================================================== +! Perform the "inverse hspan transform" (inverse function of hstform) so that +! an effective p-exponent beta filter half-span, hs, is replaced by the second +! moment (spread**2) of the dibeta filter this half-span implies. +! If the given half-span is not accommodated by the prepared table, bsprds, of +! module jp_pbfil3, return a raised failure flag, ff. +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u1 +use jp_pbfil2,only: nh,bsprds +implicit none +real(dp),intent(inout):: hs +logical, intent( out):: ff +!------------------------------------------------------------------------------ +real(dp) :: w +integer(spi):: h +!============================================================================== +h=1+int(hs) +ff=(h<2 .or. h>nh) +if(ff)then + print'(" In hstformi; hs out of bounds")' + return +endif +! Linearly interpolate the spread**2 from the table bsprds: +w=h-hs +hs=w*bsprds(h-1)+(u1-w)*bsprds(h) +end subroutine hstformi + +!==================================================================== [blinfil] +subroutine blinfil(nfil,hspan, h,fil,ff) +!============================================================================== +! Find the discrete halfspan h and the filtering weights, fil(0:h), of +! the normalized dibeta filter of formal real half-span, hspan. The dibeta +! filter is just a weighted combination of two consecutive-halfspan +! beta filters such that the spread**2 of the dibeta is the weighted +! intermediate of the spreads**2 of the pair of beta filters from which it +! is composed. +! +! p: beta filter exponent index +! nh: size of the table listing the normalization factors and spreads**2 +! bnorm: table of normalization factors for beta filters of integer halfspan +! bsprds: table of squared-spreads of the beta filters +! hspan: formal real half-span of the dibeta filter +! fil: a real array, [0:nh], sufficient to accommodate one half of the +! symmetric discrete dibeta filter. +! ff: logical failure flag raised when hspan lies outside the table range. +!============================================================================== +use jp_pkind, only: spi,dp +use jp_pietc, only: u1 +use jp_pbfil2,only: p,nh,bnorm +implicit none +integer(spi), intent(in ):: nfil +real(dp), intent(in ):: hspan +integer(spi), intent(out):: h +real(dp),dimension(0:nfil),intent(out):: fil +logical, intent(out):: ff +!------------------------------------------------------------------------------ +real(dp) :: wh,whp,z +integer(spi):: hp,i +!============================================================================== +h=int(hspan); hp=h+1; ff=h<1 .or. hp>nh .or. hp>nfil; if(ff)return +whp =(hspan-h)*bnorm(hp)! linear interpolation weight at hp=h+1 +wh=(hp-hspan)*bnorm(h)! linear interpolation weight at h +! start with the contribution of the filter of formal halfspan h+1: +do i=0,h; z=i; z=(z/hp)**2; fil(i)= whp*(u1-z)**p; enddo +! add the contribution of the filter of formal halfspan h: +do i=0,h-1; z=i; z=(z/h)**2; fil(i)=fil(i)+wh*(u1-z)**p; enddo +end subroutine blinfil + +!-- The following routines share the interface, dibeta: +!===================================================================== [dibeta] +subroutine dibeta1(kx,lx,mx,nx, nfil,dixs,hss,a,ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil):: fil +real(dp),dimension(kx:nx) :: b +real(dp) :: fili +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + dix=dixs(ix) + if(dix==0)then;b(ix)=a(ix) + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(ix)=fil(0)*a(ix) + do i=1,h + fili=fil(i); dixi=dix*i + b(ix)=b(ix)+fili*(a(ix+dixi)+a(ix-dixi)) + enddo + endif +enddo +a=b +end subroutine dibeta1 +!===================================================================== [dibeta] +subroutine dibeta2(kx,lx,mx,nx, ky,ly,my,ny, nfil, & + dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny):: b +real(dp) :: fili +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(ix,iy)=a(ix,iy) + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(ix,iy)=fil(0)*a(ix,iy) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i + b(ix,iy)=b(ix,iy)+fili*(a(ix+dixi,iy+diyi)+a(ix-dixi,iy-diyi)) + enddo + endif +enddo; enddo +a=b +end subroutine dibeta2 +!===================================================================== [dibeta] +subroutine dibeta3(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, nfil, & + dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(ix,iy,iz)=a(ix,iy,iz) + else + call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return + b(ix,iy,iz)=fil(0)*a(ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix,iy,iz)=b(ix,iy,iz)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi)& + +a(ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibeta3 +!===================================================================== [dibeta] +subroutine dibeta4(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil, dixs,diys,dizs,diws,hss, a, ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz,iw);diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw);diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then;b(ix,iy,iz,iw)=a(ix,iy,iz,iw) + else + call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=fil(0)*a(ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibeta4 + +!===================================================================== [dibeta] +subroutine dibetax3(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs + +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(ix,iy,iz)=a(ix,iy,iz) + cycle + else + jcol(ix,iy,iz)=j+1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz)=fil(0)*a(ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix,iy,iz)=b(ix,iy,iz)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi)& + +a(ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibetax3 +!===================================================================== [dibeta] +subroutine dibetax4(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),& + intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10),& + intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: jcol +real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(ix,iy,iz,iw)=a(ix,iy,iz,iw) + cycle + else + jcol(ix,iy,iz,iw)=j+1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=fil(0)*a(ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fili* & + (a(ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibetax4 + +!===================================================================== [dibeta] +subroutine vdibeta1(nv,kx,lx,mx,nx, nfil,dixs,hss,a,ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv,kx,lx,mx,nx, nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(nv,kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx) :: b +real(dp) :: fili +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + dix=dixs(ix) + if(dix==0)then; b(:,ix)=a(:,ix) + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(:,ix)=fil(0)*a(:,ix) + do i=1,h + fili=fil(i); dixi=dix*i + b(:,ix)=b(:,ix)+fili*(a(:,ix+dixi)+a(:,ix-dixi)) + enddo + endif +enddo +a=b +end subroutine vdibeta1 +!===================================================================== [dibeta] +subroutine vdibeta2(nv, kx,lx,mx,nx, ky,ly,my,ny, nfil, & + dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny):: b +real(dp) :: fili +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(:,ix,iy)=a(:,ix,iy) + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(:,ix,iy)=fil(0)*a(:,ix,iy) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i + b(:,ix,iy)=b(:,ix,iy)+fili* & + (a(:,ix+dixi,iy+diyi)+a(:,ix-dixi,iy-diyi)) + enddo + endif +enddo; enddo +a=b +end subroutine vdibeta2 +!===================================================================== [dibeta] +subroutine vdibeta3(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, nfil, & + dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(:,ix,iy,iz)=a(:,ix,iy,iz) + else + call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return + b(:,ix,iy,iz)=fil(0)*a(:,ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi)& + +a(:,ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibeta3 +!===================================================================== [dibeta] +subroutine vdibeta4(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil, dixs,diys,dizs,diws,hss, a, ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + dix=dixs(ix,iy,iz,iw);diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw);diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then + b(:,ix,iy,iz,iw)=a(:,ix,iy,iz,iw) + else + call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=fil(0)*a(:,ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibeta4 + +!===================================================================== [dibeta] +subroutine vdibetax3(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(:,ix,iy,iz)=a(:,ix,iy,iz) + cycle + else + jcol(ix,iy,iz)=j+1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz)=fil(0)*a(:,ix,iy,iz) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi)& + +a(:,ix-dixi,iy-diyi,iz-dizi)) + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibetax3 +!===================================================================== [dibeta] +subroutine vdibetax4(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:11,lx:mx,ly:my,lz:mz,lw:mw),& + intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,10),& + intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: jcol +real(dp),dimension(10,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: fili,hs +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==1)jcol=1 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(:,ix,iy,iz,iw)=a(:,ix,iy,iz,iw) + cycle + else + jcol(ix,iy,iz,iw)=j+1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=fil(0)*a(:,ix,iy,iz,iw) + do i=1,h + fili=fil(i); dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fili* & + (a(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)& + +a(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)) + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibetax4 + +!--- The following routine share the interface, dibetat: + +!==================================================================== [dibetat] +subroutine dibeta1t(kx,lx,mx,nx, nfil, dixs,hss, a, ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil):: fil +real(dp),dimension(kx:nx) :: b +real(dp) :: filiat,at +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + at=a(ix) + dix=dixs(ix) + if(dix==0)then;b(ix)=b(ix)+at + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(ix)=b(ix)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i + b(ix+dixi)=b(ix+dixi)+filiat + b(ix-dixi)=b(ix-dixi)+filiat + enddo + endif +enddo +a=b +end subroutine dibeta1t +!==================================================================== [dibetat] +subroutine dibeta2t(kx,lx,mx,nx, ky,ly,my,ny, & + nfil, dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny):: b +real(dp) :: filiat,at +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + at=a(ix,iy) + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(ix,iy)=b(ix,iy)+at + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(ix,iy)=b(ix,iy)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i + b(ix+dixi,iy+diyi)=b(ix+dixi,iy+diyi)+filiat + b(ix-dixi,iy-diyi)=b(ix-dixi,iy-diyi)+filiat + enddo + endif +enddo; enddo +a=b +end subroutine dibeta2t +!==================================================================== [dibetat] +subroutine dibeta3t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, & + nfil, dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,& + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz) + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(ix,iy,iz)=b(ix,iy,iz)+at + else + call blinfil(nfil,hss(ix,iy,iz),h,fil,ff); if(ff)return + b(ix,iy,iz)=b(ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix+dixi,iy+diyi,iz+dizi)=b(ix+dixi,iy+diyi,iz+dizi)+filiat + b(ix-dixi,iy-diyi,iz-dizi)=b(ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibeta3t + +!==================================================================== [dibetat] +subroutine dibeta4t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil,dixs,diys,dizs,diws,hss, a,ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz,iw) + dix=dixs(ix,iy,iz,iw); diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw); diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+at + else + call blinfil(nfil,hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibeta4t + +!==================================================================== [dibetat] +subroutine dibetax3t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz):: b +real(dp) :: filiat,hs,at +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==7)jcol=6 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz) + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(ix,iy,iz)=b(ix,iy,iz)+at + cycle + else + jcol(ix,iy,iz)=j-1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz)=b(ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(ix+dixi,iy+diyi,iz+dizi)=b(ix+dixi,iy+diyi,iz+dizi)+filiat + b(ix-dixi,iy-diyi,iz-dizi)=b(ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine dibetax3t + +!==================================================================== [dibetat] +subroutine dibetax4t(kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,6), intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp) :: filiat,hs,at +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==15)jcol=10 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(ix,iy,iz,iw) + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+at + cycle + else + jcol(ix,iy,iz,iw)=j-1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(ix,iy,iz,iw)=b(ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine dibetax4t + +!==================================================================== [dibetat] +subroutine vdibeta1t(nv,kx,lx,mx,nx, nfil, dixs,hss, a, ff,ix) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv,kx,lx,mx,nx,nfil +integer(fpi),dimension(lx:mx),intent(in ):: dixs +real(dp), dimension(lx:mx),intent(in ):: hss +real(dp), dimension(nv,kx:nx),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i,dix,dixi +!============================================================================== +b=u0 +do ix=lx,mx + at=a(:,ix) + dix=dixs(ix) + if(dix==0)then;b(:,ix)=b(:,ix)+at + else + call blinfil(nfil,hss(ix),h,fil,ff); if(ff)return + b(:,ix)=b(:,ix)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i + b(:,ix+dixi)=b(:,ix+dixi)+filiat + b(:,ix-dixi)=b(:,ix-dixi)+filiat + enddo + endif +enddo +a=b +end subroutine vdibeta1t +!==================================================================== [dibetat] +subroutine vdibeta2t(nv, kx,lx,mx,nx, ky,ly,my,ny, & + nfil, dixs,diys,hss, a, ff,ix,iy) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv,& + kx,lx,mx,nx,& + ky,ly,my,ny,& + nfil +integer(fpi),dimension(lx:mx,ly:my),intent(in ):: dixs,diys +real(dp), dimension(lx:mx,ly:my),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i,dix,diy,dixi,diyi +!============================================================================== +b=u0 +do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy) + dix=dixs(ix,iy); diy=diys(ix,iy) + if(abs(dix)+abs(diy)==0)then;b(:,ix,iy)=b(:,ix,iy)+at + else + call blinfil(nfil,hss(ix,iy),h,fil,ff); if(ff)return + b(:,ix,iy)=b(:,ix,iy)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i + b(:,ix+dixi,iy+diyi)=b(:,ix+dixi,iy+diyi)+filiat + b(:,ix-dixi,iy-diyi)=b(:,ix-dixi,iy-diyi)+filiat + enddo + endif +enddo; enddo +a=b +end subroutine vdibeta2t +!==================================================================== [dibetat] +subroutine vdibeta3t(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, & + nfil, dixs,diys,dizs,hss, a, ff,ix,iy,iz) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz),intent(in ):: dixs,diys,dizs +real(dp), dimension(lx:mx,ly:my,lz:mz),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,& + dixi,diyi,dizi +!============================================================================== +b=u0 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz) + dix=dixs(ix,iy,iz); diy=diys(ix,iy,iz); diz=dizs(ix,iy,iz) + if(abs(dix)+abs(diy)+abs(diz)==0)then;b(:,ix,iy,iz)=b(:,ix,iy,iz)+at + else + call blinfil(nfil, hss(ix,iy,iz),h,fil,ff); if(ff)return + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix+dixi,iy+diyi,iz+dizi)=b(:,ix+dixi,iy+diyi,iz+dizi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi)=b(:,ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibeta3t +!==================================================================== [dibetat] +subroutine vdibeta4t(nv, kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + nfil, dixs,diys,dizs,diws,hss, a,ff,ix,iy,iz,iw) +!============================================================================== +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx,& + ky,ly,my,ny,& + kz,lz,mz,nz,& + kw,lw,mw,nw,& + nfil +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: dixs,diys,& + dizs,diws +real(dp), dimension(lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: hss +real(dp), dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw),intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp),dimension(nv) :: filiat,at +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +!============================================================================== +b=u0 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz,iw) + dix=dixs(ix,iy,iz,iw); diy=diys(ix,iy,iz,iw) + diz=dizs(ix,iy,iz,iw); diw=diws(ix,iy,iz,iw) + if(abs(dix)+abs(diy)+abs(diz)+abs(diw)==0)then + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+at + else + call blinfil(nfil, hss(ix,iy,iz,iw),h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibeta4t + +!==================================================================== [dibetat] +subroutine vdibetax3t(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, icol,nfil,& + qcols,dixs,diys,dizs, jcol,hss,a, ff,ix,iy,iz) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,6), intent(in ):: dixs,diys,dizs +integer(fpi),dimension(lx:mx,ly:my,lz:mz), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz):: b +real(dp),dimension(nv) :: filiat,at +real(dp) :: hs +integer(spi) :: h,i, & + dix,diy,diz, & + dixi,diyi,dizi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==7)jcol=6 +do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz) + j=jcol(ix,iy,iz) + if(icol/=qcols(j,ix,iy,iz))then + b(:,ix,iy,iz)=b(:,ix,iy,iz)+at + cycle + else + jcol(ix,iy,iz)=j-1_fpi + dix=dixs(ix,iy,iz,j); diy=diys(ix,iy,iz,j); diz=dizs(ix,iy,iz,j) + hs=hss(j,ix,iy,iz) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz)=b(:,ix,iy,iz)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i + b(:,ix+dixi,iy+diyi,iz+dizi)=b(:,ix+dixi,iy+diyi,iz+dizi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi)=b(:,ix-dixi,iy-diyi,iz-dizi)+filiat + enddo + endif +enddo; enddo; enddo +a=b +end subroutine vdibetax3t + +!==================================================================== [dibetat] +subroutine vdibetax4t(nv,kx,lx,mx,nx, ky,ly,my,ny, kz,lz,mz,nz, kw,lw,mw,nw, & + icol,nfil,& + qcols,dixs,diys,dizs,diws, jcol,hss,a, ff,ix,iy,iz,iw) +!============================================================================= +use jp_pkind, only: spi,dp; use jp_pkind2, only: fpi +use jp_pietc, only: u0 +implicit none +integer(spi), intent(in ):: nv, & + kx,lx,mx,nx, & + ky,ly,my,ny, & + kz,lz,mz,nz, & + kw,lw,mw,nw, & + icol,nfil +integer(fpi),dimension(0:7,lx:mx,ly:my,lz:mz,lw:mw),intent(in ):: qcols +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw,6), intent(in ):: dixs,diys,& + dizs,diws +integer(fpi),dimension(lx:mx,ly:my,lz:mz,lw:mw), intent(inout):: jcol +real(dp),dimension(6,lx:mx,ly:my,lz:mz,lw:mw), intent(in ):: hss +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw), intent(inout):: a +logical, intent( out):: ff +integer(spi), intent( out):: ix,iy,iz,iw +!------------------------------------------------------------------------------ +real(dp),dimension(0:nfil) :: fil +real(dp),dimension(nv,kx:nx,ky:ny,kz:nz,kw:nw):: b +real(dp),dimension(nv) :: filiat,at +real(dp) :: hs +integer(spi) :: h,i, & + dix,diy,diz,diw, & + dixi,diyi,dizi,diwi +integer(fpi) :: j +!============================================================================== +b=u0 +if(icol==15)jcol=10 +do iw=lw,mw; do iz=lz,mz; do iy=ly,my; do ix=lx,mx + at=a(:,ix,iy,iz,iw) + j=jcol(ix,iy,iz,iw) + if(icol/=qcols(j,ix,iy,iz,iw))then + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+at + cycle + else + jcol(ix,iy,iz,iw)=j-1_fpi + dix=dixs(ix,iy,iz,iw,j); diy=diys(ix,iy,iz,iw,j) + diz=dizs(ix,iy,iz,iw,j); diw=diws(ix,iy,iz,iw,j) + hs=hss(j,ix,iy,iz,iw) + call blinfil(nfil,hs,h,fil,ff); if(ff)return + b(:,ix,iy,iz,iw)=b(:,ix,iy,iz,iw)+fil(0)*at + do i=1,h + filiat=fil(i)*at; dixi=dix*i; diyi=diy*i; dizi=diz*i; diwi=diw*i + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)= & + b(:,ix+dixi,iy+diyi,iz+dizi,iw+diwi)+filiat + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)= & + b(:,ix-dixi,iy-diyi,iz-dizi,iw-diwi)+filiat + enddo + endif +enddo; enddo; enddo; enddo +a=b +end subroutine vdibetax4t + +end module jp_pbfil3 + +!# diff --git a/src/mgbf/jp_pietc.f90 b/src/mgbf/jp_pietc.f90 new file mode 100644 index 0000000000..b102d22b7a --- /dev/null +++ b/src/mgbf/jp_pietc.f90 @@ -0,0 +1,111 @@ +module jp_pietc +!$$$ module documentation block +! . . . . +! module: jp_pietc +! prgmmr: purser org: NOAA/EMC date: 2014 +! +! abstract: Some of the commonly used constants (pi etc) +! mainly for double-precision subroutines. +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: dp,dpc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(dp),parameter:: & + u0=0,u1=1,mu1=-u1,u2=2,mu2=-u2,u3=3,mu3=-u3,u4=4,mu4=-u4,u5=5,mu5=-u5, & + u6=6,mu6=-u6,o2=u1/2,o3=u1/3,o4=u1/4,o5=u1/5,o6=u1/6, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_dp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_dp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_dp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_dp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_dp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_dp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_dp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_dp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_dp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_dp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_dp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_dp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_dp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_dp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_dp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_dp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_dp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_dp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_dp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_dp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_dp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_dp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_dp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_dp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_dp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_dp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_dp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_dp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_dp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_dp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_dp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_dp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_dp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(dpc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module jp_pietc diff --git a/src/mgbf/jp_pietc_s.f90 b/src/mgbf/jp_pietc_s.f90 new file mode 100644 index 0000000000..8f3097225b --- /dev/null +++ b/src/mgbf/jp_pietc_s.f90 @@ -0,0 +1,113 @@ +module jp_pietc_s +!$$$ module documentation block +! . . . . +! module: jp_pietc_s +! prgmmr: purser org: NOAA/EMC date: 2014 +! +! abstract: Some of the commonly used constants (pi etc) +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! ms10 etc are needed to satisfy the some (eg., gnu fortran) compilers' +! more rigorous standards regarding the way "data" statements are initialized. +! Zero and the first few units are u0,u1,u2, etc., their reciprocals being, +! o2,o3 etc and their square roots, r2,r3. Reciprocal roots are or2,or3 etc. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +!============================================================================= +use mpi +use jp_pkind, only: sp,spc +implicit none +logical ,parameter:: T=.true.,F=.false. !<- for pain-relief in logical ops +real(sp),parameter:: & + u0=0_sp,u1=1_sp,mu1=-u1,u2=2_sp,mu2=-u2,u3=3_sp,mu3=-u3,u4=4_sp, & + mu4=-u4,u5=5_sp,mu5=-u5,u6=6_sp,mu6=-u6,o2=u1/u2,o3=u1/u3,o4=u1/u4, & + o5=u1/u5,o6=u1/u6,mo2=-o2,mo3=-o3,mo4=-o4,mo5=-o5,mo6=-06, & + pi =3.1415926535897932384626433832795028841971693993751058209749e0_sp, & + pi2=6.2831853071795864769252867665590057683943387987502116419498e0_sp, & + pih=1.5707963267948966192313216916397514420985846996875529104874e0_sp, & + rpi=1.7724538509055160272981674833411451827975494561223871282138e0_sp, & +! Important square-roots + r2 =1.4142135623730950488016887242096980785696718753769480731766e0_sp, & + r3 =1.7320508075688772935274463415058723669428052538103806280558e0_sp, & + r5 =2.2360679774997896964091736687312762354406183596115257242708e0_sp, & + or2=u1/r2,or3=u1/r3,or5=u1/r5, & +! Golden number: + phi=1.6180339887498948482045868343656381177203091798057628621354e0_sp, & +! Euler-Mascheroni constant: + euler=0.57721566490153286060651209008240243104215933593992359880e0_sp, & +! Degree to radians; radians to degrees: + dtor=pi/180,rtod=180/pi, & +! Sines of all main fractions of 90 degrees (down to ninths): + s10=.173648177666930348851716626769314796000375677184069387236241e0_sp,& + s11=.195090322016128267848284868477022240927691617751954807754502e0_sp,& + s13=.222520933956314404288902564496794759466355568764544955311987e0_sp,& + s15=.258819045102520762348898837624048328349068901319930513814003e0_sp,& + s18=.309016994374947424102293417182819058860154589902881431067724e0_sp,& + s20=.342020143325668733044099614682259580763083367514160628465048e0_sp,& + s22=.382683432365089771728459984030398866761344562485627041433800e0_sp,& + s26=.433883739117558120475768332848358754609990727787459876444547e0_sp,& + s30=o2, & + s34=.555570233019602224742830813948532874374937190754804045924153e0_sp,& + s36=.587785252292473129168705954639072768597652437643145991072272e0_sp,& + s39=.623489801858733530525004884004239810632274730896402105365549e0_sp,& + s40=.642787609686539326322643409907263432907559884205681790324977e0_sp,& + s45=or2, & + s50=.766044443118978035202392650555416673935832457080395245854045e0_sp,& + s51=.781831482468029808708444526674057750232334518708687528980634e0_sp,& + s54=.809016994374947424102293417182819058860154589902881431067724e0_sp,& + s56=.831469612302545237078788377617905756738560811987249963446124e0_sp,& + s60=r3*o2, & + s64=.900968867902419126236102319507445051165919162131857150053562e0_sp,& + s68=.923879532511286756128183189396788286822416625863642486115097e0_sp,& + s70=.939692620785908384054109277324731469936208134264464633090286e0_sp,& + s72=.951056516295153572116439333379382143405698634125750222447305e0_sp,& + s75=.965925826289068286749743199728897367633904839008404550402343e0_sp,& + s77=.974927912181823607018131682993931217232785800619997437648079e0_sp,& + s79=.980785280403230449126182236134239036973933730893336095002916e0_sp,& + s80=.984807753012208059366743024589523013670643251719842418790025e0_sp,& +! ... and their minuses: + ms10=-s10,ms11=-s11,ms13=-s13,ms15=-s15,ms18=-s18,ms20=-s20,ms22=-s22,& + ms26=-s26,ms30=-s30,ms34=-s34,ms36=-s36,ms39=-s39,ms40=-s40,ms45=-s45,& + ms50=-s50,ms51=-s51,ms54=-s54,ms56=-s56,ms60=-s60,ms64=-s64,ms68=-s68,& + ms70=-s70,ms72=-s72,ms75=-s75,ms77=-s77,ms79=-s79,ms80=-s80 + +complex(spc),parameter:: & + c0=(u0,u0),c1=(u1,u0),mc1=-c1,ci=(u0,u1),mci=-ci,cipi=ci*pi, & +! Main fractional rotations, as unimodualr complex numbers: + z000=c1 ,z010=( s80,s10),z011=( s79,s11),z013=( s77,s13),& + z015=( s75,s15),z018=( s72,s18),z020=( s70,s20),z022=( s68,s22),& + z026=( s64,s26),z030=( s60,s30),z034=( s56,s34),z036=( s54,s36),& + z039=( s51,s39),z040=( s50,s40),z045=( s45,s45),z050=( s40,s50),& + z051=( s39,s51),z054=( s36,s54),z056=( s34,s56),z060=( s30,s60),& + z064=( s26,s64),z068=( s22,s68),z070=( s20,s70),z072=( s18,s72),& + z075=( s15,s75),z077=( s13,s77),z079=( s11,s79),z080=( s10,s80),& + z090=ci, z100=(ms10,s80),z101=(ms11,s79),z103=(ms13,s77),& + z105=(ms15,s75),z108=(ms18,s72),z110=(ms20,s70),z112=(ms22,s68),& + z116=(ms26,s64),z120=(ms30,s60),z124=(ms34,s56),z126=(ms36,s54),& + z129=(ms39,s51),z130=(ms40,s50),z135=(ms45,s45),z140=(ms50,s40),& + z141=(ms51,s39),z144=(ms54,s36),z146=(ms56,s34),z150=(ms60,s30),& + z154=(ms64,s26),z158=(ms68,s22),z160=(ms70,s20),z162=(ms72,s18),& + z165=(ms75,s15),z167=(ms77,s13),z169=(ms79,s11),z170=(ms80,s10),& + z180=-z000,z190=-z010,z191=-z011,z193=-z013,z195=-z015,z198=-z018,& + z200=-z020,z202=-z022,z206=-z026,z210=-z030,z214=-z034,z216=-z036,& + z219=-z039,z220=-z040,z225=-z045,z230=-z050,z231=-z051,z234=-z054,& + z236=-z056,z240=-z060,z244=-z064,z248=-z068,z250=-z070,z252=-z072,& + z255=-z075,z257=-z077,z259=-z079,z260=-z080,z270=-z090,z280=-z100,& + z281=-z101,z283=-z103,z285=-z105,z288=-z108,z290=-z110,z292=-z112,& + z296=-z116,z300=-z120,z304=-z124,z306=-z126,z309=-z129,z310=-z130,& + z315=-z135,z320=-z140,z321=-z141,z324=-z144,z326=-z146,z330=-z150,& + z334=-z154,z338=-z158,z340=-z160,z342=-z162,z345=-z165,z347=-z167,& + z349=-z169,z350=-z170 +end module jp_pietc_s + diff --git a/src/mgbf/jp_pkind.f90 b/src/mgbf/jp_pkind.f90 new file mode 100644 index 0000000000..cdbf19f4eb --- /dev/null +++ b/src/mgbf/jp_pkind.f90 @@ -0,0 +1,34 @@ +module jp_pkind +!$$$ module documentation block +! . . . . +! module: jp_pkind +! +! abstract: Kinds for single- and double-precision +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +integer,parameter:: spi=selected_int_kind(6),& + dpi=selected_int_kind(12),& + sp =selected_real_kind(6,30),& + dp =selected_real_kind(15,300),& + spc=sp,dpc=dp +!private:: one_dpi; integer(8),parameter:: one_dpi=1 +!integer,parameter:: dpi=kind(one_dpi) +!integer,parameter:: sp=kind(1.0) +!integer,parameter:: dp=kind(1.0d0) +!integer,parameter:: spc=kind((1.0,1.0)) +!integer,parameter:: dpc=kind((1.0d0,1.0d0)) +end module jp_pkind diff --git a/src/mgbf/jp_pkind2.f90 b/src/mgbf/jp_pkind2.f90 new file mode 100644 index 0000000000..3dcecc5635 --- /dev/null +++ b/src/mgbf/jp_pkind2.f90 @@ -0,0 +1,25 @@ +module jp_pkind2 +!$$$ module documentation block +! . . . . +! module: jp_pkind2 +! +! abstract: Integer kinds for helf- and fourth-precision integers +! +! module history log: +! +! Subroutines Included: +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +integer,parameter:: hpi=selected_int_kind(3),& + fpi=selected_int_kind(2) +end module jp_pkind2 diff --git a/src/mgbf/jp_pmat.f90 b/src/mgbf/jp_pmat.f90 new file mode 100644 index 0000000000..f139feea06 --- /dev/null +++ b/src/mgbf/jp_pmat.f90 @@ -0,0 +1,1096 @@ +module jp_pmat +!$$$ module documentation block +! . . . . +! module: jp_pmat +! prgmmr: fujita org: NOAA/EMC date: 1993 +! +! abstract: Utility routines for various linear inversions and Cholesky +! +! module history log: +! 2002 purser +! 2009 purser +! 2012 purser +! +! Subroutines Included: +! swpvv - +! inv - +! ldum - +! udlmm - +! l1lm - +! ldlm - +! invu - +! invl - +! +! Functions Included: +! +! remarks: +! Originally, these routines were copies of the purely "inversion" members +! of pmat1.f90 (a most extensive collection of matrix routines -- not just +! inversions). As well as having both single and double precision versions +! of each routine, these versions also make provision for a more graceful +! termination in cases where the system matrix is detected to be +! essentially singular (and therefore noninvertible). This provision takes +! the form of an optional "failure flag", FF, which is normally returned +! as .FALSE., but is returned as .TRUE. when inversion fails. +! In Sep 2012, these routines were collected together into jp_pmat.f90 so +! that all the main matrix routines could be in the same library, jp_pmat.a. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: sp,dp,spc,dpc +use jp_pietc, only: t,f +implicit none +private +public:: ldum,udlmm,inv,L1Lm,LdLm,invl,invu +interface swpvv; module procedure sswpvv,dswpvv,cswpvv; end interface +interface ldum + module procedure sldum,dldum,cldum,sldumf,dldumf,cldumf; end interface +interface udlmm + module procedure sudlmm,dudlmm,cudlmm,sudlmv,dudlmv,cudlmv; end interface +interface inv + module procedure & +sinvmt, dinvmt, cinvmt, slinmmt, dlinmmt, clinmmt, slinmvt, dlinmvt, clinmvt, & +sinvmtf,dinvmtf,cinvmtf,slinmmtf,dlinmmtf,clinmmtf,slinmvtf,dlinmvtf,clinmvtf,& +iinvf + end interface +interface L1Lm; module procedure sL1Lm,dL1Lm,sL1Lmf,dL1Lmf; end interface +interface LdLm; module procedure sLdLm,dLdLm,sLdLmf,dLdLmf; end interface +interface invl; module procedure sinvl,dinvl,slinlv,dlinlv; end interface +interface invu; module procedure sinvu,dinvu,slinuv,dlinuv; end interface + +contains + +!============================================================================= +subroutine sswpvv(d,e)! [swpvv] +!============================================================================= +! Swap vectors +!------------- +real(sp), intent(inout) :: d(:), e(:) +real(sp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine sswpvv +!============================================================================= +subroutine dswpvv(d,e)! [swpvv] +!============================================================================= +real(dp), intent(inout) :: d(:), e(:) +real(dp) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine dswpvv +!============================================================================= +subroutine cswpvv(d,e)! [swpvv] +!============================================================================= +complex(dpc),intent(inout) :: d(:), e(:) +complex(dpc) :: tv(size(d)) +!============================================================================= +tv = d; d = e; e = tv +end subroutine cswpvv + +!============================================================================= +subroutine sinvmt(a)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(INOUT):: a +logical :: ff +call sinvmtf(a,ff) +if(ff)stop 'In sinvmt; Unable to invert matrix' +end subroutine sinvmt +!============================================================================= +subroutine dinvmt(a)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +logical :: ff +call dinvmtf(a,ff) +if(ff)stop 'In dinvmt; Unable to invert matrix' +end subroutine dinvmt +!============================================================================= +subroutine cinvmt(a)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +logical :: ff +call cinvmtf(a,ff) +if(ff)stop 'In cinvmt; Unable to invert matrix' +end subroutine cinvmt +!============================================================================= +subroutine sinvmtf(a,ff)! [inv] +!============================================================================= +! Invert matrix (or flag if can't) +!---------------- +real(sp),dimension(:,:),intent(inout):: a +logical, intent( out):: ff +integer :: m,i,j,jp,l +real(sp) :: d +integer,dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In sinvmtf; matrix passed to sinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call sldumf(a,ipiv,d,ff) +if(ff)then + print '(" In sinvmtf; failed call to sldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1./a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call sswpvv(a(:,j),a(:,l)); enddo +end subroutine sinvmtf +!============================================================================= +subroutine dinvmtf(a,ff)! [inv] +!============================================================================= +real(DP),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +real(DP) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call dldumf(a,ipiv,d,ff) +if(ff)then + print '(" In dinvmtf; failed call to dldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*dot_product(a(i:j-1,j),a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-dot_product(a(jp:i-1,j),a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+dot_product(a(jp:m,j),a(i,jp:m)); enddo + do i=jp,m; a(i,j)=dot_product(a(i:m,j),a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call dswpvv(a(:,j),a(:,l)); enddo +end subroutine dinvmtf +!============================================================================= +subroutine cinvmtf(a,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a +logical, intent( OUT):: ff +integer :: m,i,j,jp,l +complex(dpc) :: d +integer, dimension(size(a,1)) :: ipiv +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to cinvmtf is not square' +! Perform a pivoted L-D-U decomposition on matrix a: +call cldumf(a,ipiv,d,ff) +if(ff)then + print '(" In cinvmtf; failed call to cldumf")' + return +endif + +! Invert upper triangular portion U in place: +do i=1,m; a(i,i)=1/a(i,i); enddo +do i=1,m-1 + do j=i+1,m; a(i,j)=-a(j,j)*sum(a(i:j-1,j)*a(i,i:j-1)); enddo +enddo + +! Invert lower triangular portion L in place: +do j=1,m-1; jp=j+1 + do i=jp,m; a(i,j)=-a(i,j)-sum(a(jp:i-1,j)*a(i,jp:i-1)); enddo +enddo + +! Form the product of U**-1 and L**-1 in place +do j=1,m-1; jp=j+1 + do i=1,j; a(i,j)=a(i,j)+sum(a(jp:m,j)*a(i,jp:m)); enddo + do i=jp,m; a(i,j)=sum(a(i:m,j)*a(i,i:m)); enddo +enddo + +! Permute columns according to ipiv +do j=m-1,1,-1; l=ipiv(j); call cswpvv(a(:,j),a(:,l)); enddo +end subroutine cinvmtf + +!============================================================================= +subroutine slinmmt(a,b)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a,b +logical :: ff +call slinmmtf(a,b,ff) +if(ff)stop 'In slinmmt; unable to invert linear system' +end subroutine slinmmt +!============================================================================= +subroutine dlinmmt(a,b)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a,b +logical :: ff +call dlinmmtf(a,b,ff) +if(ff)stop 'In dlinmmt; unable to invert linear system' +end subroutine dlinmmt +!============================================================================= +subroutine clinmmt(a,b)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a,b +logical :: ff +call clinmmtf(a,b,ff) +if(ff)stop 'In clinmmt; unable to invert linear system' +end subroutine clinmmt +!============================================================================= +subroutine slinmmtf(a,b,ff)! [inv] +!============================================================================= +real(SP), dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer,dimension(size(a,1)) :: ipiv +integer :: m +real(sp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to slinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in slinmmtf have unmatched sizes' +call sldumf(a,ipiv,d,ff) +if(ff)then + print '("In slinmmtf; failed call to sldumf")' + return +endif +call sudlmm(a,b,ipiv) +end subroutine slinmmtf +!============================================================================= +subroutine dlinmmtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:), intent(inout):: a,b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +real(dp) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call dldumf(a,ipiv,d,ff) +if(ff)then + print '("In dlinmmtf; failed call to dldumf")' + return +endif +call dudlmm(a,b,ipiv) +end subroutine dlinmmtf +!============================================================================= +subroutine clinmmtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(INOUT):: a,b +logical, intent( OUT):: ff +integer, dimension(size(a,1)) :: ipiv +integer :: m +complex(dpc) :: d +!============================================================================= +m=size(a,1) +if(m /= size(a,2))stop 'In inv; matrix passed to dlinmmtf is not square' +if(m /= size(b,1))& + stop 'In inv; matrix and vectors in dlinmmtf have unmatched sizes' +call cldumf(a,ipiv,d,ff) +if(ff)then + print '("In clinmmtf; failed call to cldumf")' + return +endif +call cudlmm(a,b,ipiv) +end subroutine clinmmtf + +!============================================================================= +subroutine slinmvt(a,b)! [inv] +!============================================================================= +real(sp), dimension(:,:),intent(inout):: a +real(sp), dimension(:), intent(inout):: b +logical :: ff +call slinmvtf(a,b,ff) +if(ff)stop 'In slinmvt; matrix singular, unable to continue' +end subroutine slinmvt +!============================================================================= +subroutine dlinmvt(a,b)! [inv] +!============================================================================= +real(dp), dimension(:,:),intent(inout):: a +real(dp), dimension(:), intent(inout):: b +logical :: ff +call dlinmvtf(a,b,ff) +if(ff)stop 'In dlinmvt; matrix singular, unable to continue' +end subroutine dlinmvt +!============================================================================= +subroutine clinmvt(a,b)! [inv] +!============================================================================= +complex(dpc), dimension(:,:),intent(inout):: a +complex(dpc), dimension(:), intent(inout):: b +logical :: ff +call clinmvtf(a,b,ff) +if(ff)stop 'In clinmvt; matrix singular, unable to continue' +end subroutine clinmvt +!============================================================================= +subroutine slinmvtf(a,b,ff)! [inv] +!============================================================================= +real(sp),dimension(:,:),intent(inout):: a +real(sp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer,dimension(size(a,1)) :: ipiv +real(sp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; In slinmvtf; incompatible array dimensions' +call sldumf(a,ipiv,d,ff) +if(ff)then + print '("In slinmvtf; failed call to sldumf")' + return +endif +call sudlmv(a,b,ipiv) +end subroutine slinmvtf +!============================================================================= +subroutine dlinmvtf(a,b,ff)! [inv] +!============================================================================= +real(dp),dimension(:,:),intent(inout):: a +real(dp),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +real(dp) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to dlinmvtf' +call dldumf(a,ipiv,d,ff) +if(ff)then + print '("In dlinmvtf; failed call to dldumf")' + return +endif +call dudlmv(a,b,ipiv) +end subroutine dlinmvtf +!============================================================================= +subroutine clinmvtf(a,b,ff)! [inv] +!============================================================================= +complex(dpc),dimension(:,:),intent(inout):: a +complex(dpc),dimension(:), intent(inout):: b +logical, intent( out):: ff +integer, dimension(size(a,1)) :: ipiv +complex(dpc) :: d +!============================================================================= +if(size(a,1) /= size(a,2).or. size(a,1) /= size(b))& + stop 'In inv; incompatible array dimensions passed to clinmvtf' +call cldumf(a,ipiv,d,ff) +if(ff)then + print '("In clinmvtf; failed call to cldumf")' + return +endif +call cudlmv(a,b,ipiv) +end subroutine clinmvtf + +!============================================================================= +subroutine iinvf(imat,ff)! [inv] +!============================================================================= +! Invert integer square array, imat, if possible, but flag ff=.true. +! if not possible. (Determinant of imat must be +1 or -1 +!============================================================================= +integer,dimension(:,:),intent(INOUT):: imat +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +real(dp),parameter :: eps=1.e-10_dp +real(dp),dimension(size(imat,1),size(imat,1)):: dmat +integer :: m,i,j +!============================================================================= +m=size(imat,1) +if(m /= size(imat,2))stop 'In inv; matrix passed to iinvf is not square' +dmat=imat; call inv(dmat,ff) +if(.not.ff)then + do j=1,m + do i=1,m + imat(i,j)=nint(dmat(i,j)); if(abs(dmat(i,j)-imat(i,j))>eps)ff=t + enddo + enddo +endif +end subroutine iinvf + +!============================================================================= +subroutine sldum(a,ipiv,d)! [ldum] +!============================================================================= +real(sp),intent(inout) :: a(:,:) +real(sp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical :: ff +call sldumf(a,ipiv,d,ff) +if(ff)stop 'In sldum; matrix singular, unable to continue' +end subroutine sldum +!============================================================================= +subroutine dldum(a,ipiv,d)! [ldum] +!============================================================================= +real(dp),intent(inout) :: a(:,:) +real(dp),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call dldumf(a,ipiv,d,ff) +if(ff)stop 'In dldum; matrix singular, unable to continue' +end subroutine dldum +!============================================================================= +subroutine cldum(a,ipiv,d)! [ldum] +!============================================================================= +complex(dpc),intent(inout) :: a(:,:) +complex(dpc),intent(out ) :: d +integer, intent(out ) :: ipiv(:) +logical:: ff +call cldumf(a,ipiv,d,ff) +if(ff)stop 'In cldum; matrix singular, unable to continue' +end subroutine cldum +!============================================================================= +subroutine sldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +! R.J.Purser, NCEP, Washington D.C. 1996 +! SUBROUTINE LDUM +! perform l-d-u decomposition of square matrix a in place with +! pivoting. +! +! <-> a square matrix to be factorized +! <-- ipiv array encoding the pivoting sequence +! <-- d indicator for possible sign change of determinant +! <-- ff: failure flag, set to .true. when determinant of a vanishes. +!============================================================================= +real(SP),intent(INOUT) :: a(:,:) +real(SP),intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(SP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In sldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call sswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + print '(" failure in sldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine sldumf +!============================================================================= +subroutine DLDUMf(A,IPIV,D,ff)! [ldum] +!============================================================================= +real(DP), intent(INOUT) :: a(:,:) +real(DP), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +real(DP) :: s(size(a,1)), aam, aa, abig, ajj, ajji, aij +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In dldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call dswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == 0)then + jm=j-1 + print '(" Failure in dldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine DLDUMf +!============================================================================= +subroutine cldumf(a,ipiv,d,ff)! [ldum] +!============================================================================= +use jp_pietc, only: c0 +complex(dpc), intent(INOUT) :: a(:,:) +complex(dpc), intent(OUT ) :: d +integer, intent(OUT ) :: ipiv(:) +logical, intent(OUT ) :: ff +integer :: m,i, j, jp, ibig, jm +complex(dpc) :: ajj, ajji, aij +real(dp) :: aam,aa,abig +real(dp),dimension(size(a,1)):: s +!============================================================================= +ff=f +m=size(a,1) +do i=1,m + aam=0 + do j=1,m + aa=abs(a(i,j)) + if(aa > aam)aam=aa + enddo + if(aam == 0)then + print '("In cldumf; row ",i6," of matrix vanishes")',i + ff=t + return + endif + s(i)=1/aam +enddo +d=1. +ipiv(m)=m +do j=1,m-1 + jp=j+1 + abig=s(j)*abs(a(j,j)) + ibig=j + do i=jp,m + aa=s(i)*abs(a(i,j)) + if(aa > abig)then + ibig=i + abig=aa + endif + enddo +! swap rows, recording changed sign of determinant + ipiv(j)=ibig + if(ibig /= j)then + d=-d + call cswpvv(a(j,:),a(ibig,:)) + s(ibig)=s(j) + endif + ajj=a(j,j) + if(ajj == c0)then + jm=j-1 + print '(" Failure in cldumf:"/" matrix singular, rank=",i3)',jm + ff=t + return + endif + ajji=1/ajj + do i=jp,m + aij=ajji*a(i,j) + a(i,j)=aij + a(i,jp:m) = a(i,jp:m) - aij*a(j,jp:m) + enddo +enddo +end subroutine cldumf + +!============================================================================= +subroutine sudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMM +! use l-u factors in A to back-substitute for several rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrux +! <-> B rt-hand-sides vectors on input, corresponding solutions on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1,size(b,2) !loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine sudlmm +!============================================================================= +subroutine dudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +real(dp), dimension(:,:),intent(in ) :: a +real(dp), dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine dudlmm +!============================================================================= +subroutine cudlmm(a,b,ipiv)! [udlmm] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv +complex(dpc),dimension(:,:),intent(in ) :: a +complex(dpc),dimension(:,:),intent(inout) :: b +integer :: m,i, k, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do k=1, size(b,2)!loop over columns of b + do i=1,m + l=ipiv(i) + s=b(l,k) + b(l,k)=b(i,k) + s = s - sum(b(1:i-1,k)*a(i,1:i-1)) + b(i,k)=s + enddo + b(m,k)=b(m,k)/a(m,m) + do i=m-1,1,-1 + aiii=1/a(i,i) + b(i,k) = b(i,k) - sum(b(i+1:m,k)*a(i,i+1:m)) + b(i,k)=b(i,k)*aiii + enddo +enddo +end subroutine cudlmm + +!============================================================================= +subroutine sudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +! R.J.Purser, National Meteorological Center, Washington D.C. 1993 +! SUBROUTINE UDLMV +! use l-u factors in A to back-substitute for 1 rhs in B, using ipiv to +! define the pivoting permutation used in the l-u decomposition. +! +! --> A L-D-U factorization of linear system matrix +! <-> B right-hand-side vector on input, corresponding solution on return +! --> IPIV array encoding the pivoting sequence +!============================================================================= +integer, dimension(:), intent(in) :: ipiv +real(sp),dimension(:,:),intent(in) :: a +real(sp),dimension(:), intent(inout) :: b +integer :: m,i, l +real(sp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine sudlmv +!============================================================================= +subroutine dudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +real(dp), dimension(:,:),intent(in ) :: a(:,:) +real(dp), dimension(:), intent(inout) :: b(:) +integer :: m,i, l +real(dp) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine dudlmv +!============================================================================= +subroutine cudlmv(a,b,ipiv)! [udlmv] +!============================================================================= +integer, dimension(:), intent(in ) :: ipiv(:) +complex(dpc),dimension(:,:),intent(in ) :: a(:,:) +complex(dpc),dimension(:), intent(inout) :: b(:) +integer :: m,i, l +complex(dpc) :: s,aiii +!============================================================================= +m=size(a,1) +do i=1,m + l=ipiv(i) + s=b(l) + b(l)=b(i) + s = s - sum(b(1:i-1)*a(i,1:i-1)) + b(i)=s +enddo +b(m)=b(m)/a(m,m) +do i=m-1,1,-1 + aiii=1/a(i,i) + b(i) = b(i) - sum(b(i+1:m)*a(i,i+1:m)) + b(i)=b(i)*aiii +enddo +end subroutine cudlmv + +!============================================================================= +subroutine sl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(in ) :: a(:,:) +real(sp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call sl1lmf(a,b,ff) +if(ff)stop 'In sl1lm; matrix singular, unable to continue' +end subroutine sl1lm +!============================================================================= +subroutine dl1lm(a,b) ! [l1lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: b(:,:) +!----------------------------------------------------------------------------- +logical:: ff +call dl1lmf(a,b,ff) +if(ff)stop 'In dl1lm; matrix singular, unable to continue' +end subroutine dl1lm + +!============================================================================= +subroutine sl1lmf(a,b,ff)! [L1Lm] +!============================================================================= +! Cholesky, M -> L*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ) :: a(:,:) +real(sp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(S <= 0) + if(ff)then + print '("sL1Lmf detects nonpositive a, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +end subroutine sl1lmf +!============================================================================= +subroutine dl1lmf(a,b,ff) ! [L1Lm] +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +logical :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: s, bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + s = a(j,j) - sum(b(j,1:jm)*b(j,1:jm)) + ff=(s <= 0) + if(ff)then + print '("dL1LMF detects nonpositive A, rank=",i6)',jm + return + endif + b(j,j)=sqrt(s) + bjji=1/b(j,j) + do i=jp,m + s = a(i,j) - sum(b(i,1:jm)*b(j,1:jm)) + b(i,j)=s*bjji + enddo + b(1:jm,j) = 0 +enddo +return +end subroutine dl1lmf + +!============================================================================= +subroutine sldlm(a,b,d)! [LdLm] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call sldlmf(a,b,d,ff) +if(ff)stop 'In sldlm; matrix singular, unable to continue' +end subroutine sldlm +!============================================================================= +subroutine dldlm(a,b,d)! [LdLm] +!============================================================================= +real(dp), intent(IN ):: a(:,:) +real(dp), intent(INOUT):: b(:,:) +real(dp), intent( OUT):: d(:) +!----------------------------------------------------------------------------- +logical:: ff +call dldlmf(a,b,d,ff) +if(ff)stop 'In dldlm; matrix singular, unable to continue' +end subroutine dldlm + +!============================================================================= +subroutine sldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky decompose Q --> L*D*U +!============================================================================= +real(sp), intent(IN ):: a(:,:) +real(sp), intent(INOUT):: b(:,:) +real(sp), intent( OUT):: d(:) +logical, intent( OUT):: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(sp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m + jm=j-1 + jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + print '("In sldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine sldlmf +!============================================================================= +subroutine dldlmf(a,b,d,ff) ! [LDLM] +!============================================================================= +! Modified Cholesky Q --> L*D*U, U(i,j)=L(j,i) +!============================================================================= +real(dp), intent(IN ) :: a(:,:) +real(dp), intent(INOUT) :: b(:,:) +real(dp), intent( OUT) :: d(:) +logical, intent( OUT) :: ff +!----------------------------------------------------------------------------- +integer :: m,j, jm, jp, i +real(dp) :: bjji +!============================================================================= +m=size(a,1) +ff=f +do j=1,m; jm=j-1; jp=j+1 + d(j)=a(j,j) - sum(b(1:jm,j)*b(j,1:jm)) + b(j,j) = 1 + ff=(d(j) == 0) + if(ff)then + print '("In dldlmf; singularity of matrix detected")' + print '("Rank of matrix: ",i6)',jm + return + endif + bjji=1/d(j) + do i=jp,m + b(j,i)=a(i,j) - dot_product(b(1:jm,j),b(i,1:jm)) + b(i,j)=b(j,i)*bjji + enddo + b(1:jm,j)=0 +enddo +end subroutine dldlmf + +!============================================================================== +subroutine sinvu(a)! [invu] +!============================================================================== +! Invert the upper triangular matrix in place by transposing, calling +! invl, and transposing again. +!============================================================================== +real,dimension(:,:),intent(inout):: a +a=transpose(a); call sinvl(a); a=transpose(a) +end subroutine sinvu +!============================================================================== +subroutine dinvu(a)! [invu] +!============================================================================== +real(dp),dimension(:,:),intent(inout):: a +a=transpose(a); call dinvl(a); a=transpose(a) +end subroutine dinvu +!============================================================================== +subroutine sinvl(a)! [invl] +!============================================================================== +! Invert lower triangular matrix in place +!============================================================================== +real(sp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine sinvl +!============================================================================== +subroutine dinvl(a)! [invl] +!============================================================================== +real(dp), intent(inout) :: a(:,:) +integer :: m,j, i +m=size(a,1) +do j=m,1,-1 + a(1:j-1,j) = 0.0 + a(j,j)=1./a(j,j) + do i=j+1,m + a(i,j)=-a(i,i)*sum(a(j:i-1,j)*a(i,j:i-1)) + enddo +enddo +end subroutine dinvl + +!============================================================================== +subroutine slinlv(a,u)! [invl] +!============================================================================== +! Solve linear system involving lower triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In slinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine slinlv +!============================================================================== +subroutine dlinlv(a,u)! [invl] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinlv; incompatible array dimensions' +do i=1,size(u); u(i)=(u(i) - sum(u(:i-1)*a(i,:i-1)))/a(i,i); enddo +end subroutine dlinlv + +!============================================================================== +subroutine slinuv(a,u)! [invu] +!============================================================================== +! Solve linear system involving upper triangular system matrix. +!============================================================================== +real, intent(in ) :: a(:,:) +real, intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In linuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine slinuv +!============================================================================== +subroutine dlinuv(a,u)! [invu] +!============================================================================== +real(dp), intent(in ) :: a(:,:) +real(dp), intent(inout) :: u(:) +integer :: i +if(size(a,1) /= size(a,2) .or. size(a,1) /= size(u))& + stop 'In dlinuv; incompatible array dimensions' +do i=size(u),1,-1; u(i)=(u(i) - sum(a(i+1:,i)*u(i+1:)))/a(i,i); enddo +end subroutine dlinuv + +end module jp_pmat + diff --git a/src/mgbf/jp_pmat4.f90 b/src/mgbf/jp_pmat4.f90 new file mode 100644 index 0000000000..552d5efdeb --- /dev/null +++ b/src/mgbf/jp_pmat4.f90 @@ -0,0 +1,2086 @@ +module jp_pmat4 +!$$$ module documentation block +! . . . . +! module: jp_pmat4 +! prgmmr: purser org: NOAA/EMC date: 2005-10 +! +! abstract: Euclidean geometry, geometric (stereographic) projections, +! related transformations (Mobius) +! +! module history log: +! 2012-05-18 purser +! 2017-05 purser - Added routines to facilitate manipulation of 3D +! rotations, their representations by axial vectors, +! and routines to compute the exponentials of matrices +! (without resort to eigen methods). +! Also added Quaternion and spinor representations +! of 3D rotations, and their conversion routines. +! +! Subroutines Included: +! gram - Right-handed orthogonal basis and rank, nrank. The first +! nrank basis vectors span the column range of matrix given, +! OR ("plain" version) simple unpivoted Gram-Schmidt of a +! square matrix. +! +! In addition, we include routines that relate to +! stereographic projections and some associated mobius +! transformation utilities, since these complex operations +! have a strong geometrical flavor. +! dlltoxy - +! normalize - +! rowops - +! corral - +! rottoax - +! axtorot - +! spintoq - +! qtospin - +! rottoq - +! qtorot - +! axtoq - +! qtoax - +! setem - +! expmat - +! zntay - +! znfun - +! ctoz - +! ztoc - +! setmobius - +! mobius - +! mobiusi - +! +! Functions Included: +! absv - Absolute magnitude of vector as its euclidean length +! normalized - Normalized version of given real vector +! orthogonalized - Orthogonalized version of second vector rel. to first unit v. +! cross_product - Vector cross-product of the given 2 vectors +! outer_product - outer-product matrix of the given 2 vectors +! triple_product - Scalar triple product of given 3 vectors +! det - Determinant of given matrix +! axial - Convert axial-vector <--> 2-form (antisymmetric matrix) +! diag - Diagnl of given matrix, or diagonal matrix of given elements +! trace - Trace of given matrix +! identity - Identity 3*3 matrix, or identity n*n matrix for a given n +! sarea - Spherical area subtended by three vectors, or by lat-lon +! increments forming a triangle or quadrilateral +! huarea - Spherical area subtended by right-angled spherical triangle +! hav - +! mulqq - +! +! remarks: +! Package for handy vector and matrix operations in Euclidean geometry. +! This package is primarily intended for 3D operations and three of the +! functions (Cross_product, Triple_product and Axial) do not possess simple +! generalizations to a generic number N of dimensions. The others, while +! admitting such N-dimensional generalizations, have not all been provided +! with such generic forms here at the time of writing, though some of these +! may be added at a future date. +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use jp_pkind, only: spi,sp,dp,dpc +implicit none +private +public:: absv,normalized,orthogonalized, & + cross_product,outer_product,triple_product,det,axial, & + diag,trace,identity,sarea,huarea,dlltoxy, & + normalize,gram,rowops,corral, & + axtoq,qtoax, & + rottoax,axtorot,spintoq,qtospin,rottoq,qtorot,mulqq, & + expmat,zntay,znfun, & + ctoz,ztoc,setmobius, & + mobius,mobiusi + +interface absv; module procedure absv_s,absv_d; end interface +interface normalized;module procedure normalized_s,normalized_d;end interface +interface orthogonalized + module procedure orthogonalized_s,orthogonalized_d; end interface +interface cross_product + module procedure cross_product_s,cross_product_d, & + triple_cross_product_s,triple_cross_product_d; end interface +interface outer_product + module procedure outer_product_s,outer_product_d,outer_product_i + end interface +interface triple_product + module procedure triple_product_s,triple_product_d; end interface +interface det; module procedure det_s,det_d,det_i,det_id; end interface +interface axial + module procedure axial3_s,axial3_d,axial33_s,axial33_d; end interface +interface diag + module procedure diagn_s,diagn_d,diagn_i,diagnn_s,diagnn_d,diagnn_i + end interface +interface trace; module procedure trace_s,trace_d,trace_i; end interface +interface identity; module procedure identity_i,identity3_i; end interface +interface huarea; module procedure huarea_s,huarea_d; end interface +interface sarea + module procedure sarea_s,sarea_d,dtarea_s,dtarea_d,dqarea_s,dqarea_d + end interface +interface dlltoxy; module procedure dlltoxy_s,dlltoxy_d; end interface +interface hav; module procedure hav_s, hav_d; end interface +interface normalize;module procedure normalize_s,normalize_d; end interface +interface gram + module procedure gram_s,gram_d,graml_d,plaingram_s,plaingram_d,rowgram + end interface +interface rowops; module procedure rowops; end interface +interface corral; module procedure corral; end interface +interface rottoax; module procedure rottoax; end interface +interface axtorot; module procedure axtorot; end interface +interface spintoq; module procedure spintoq; end interface +interface qtospin; module procedure qtospin; end interface +interface rottoq; module procedure rottoq; end interface +interface qtorot; module procedure qtorot; end interface +interface axtoq; module procedure axtoq; end interface +interface qtoax; module procedure qtoax; end interface +interface setem; module procedure setem; end interface +interface mulqq; module procedure mulqq; end interface +interface expmat; module procedure expmat,expmatd,expmatdd; end interface +interface zntay; module procedure zntay; end interface +interface znfun; module procedure znfun; end interface +interface ctoz; module procedure ctoz; end interface +interface ztoc; module procedure ztoc,ztocd; end interface +interface setmobius;module procedure setmobius,zsetmobius; end interface +interface mobius; module procedure zmobius,cmobius; end interface +interface mobiusi; module procedure zmobiusi; end interface + +contains + +!============================================================================= +function absv_s(a)result(s)! [absv] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: a +real(sp) :: s +s=sqrt(dot_product(a,a)) +end function absv_s +!============================================================================= +function absv_d(a)result(s)! [absv] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: a +real(dp) :: s +s=sqrt(dot_product(a,a)) +end function absv_d + +!============================================================================= +function normalized_s(a)result(b)! [normalized] +!============================================================================= +use jp_pietc_s, only: u0 +implicit none +real(sp),dimension(:),intent(IN):: a +real(sp),dimension(size(a)) :: b +real(sp) :: s +s=absv_s(a); if(s==u0)then; b=u0;else;b=a/s;endif +end function normalized_s +!============================================================================= +function normalized_d(a)result(b)! [normalized] +!============================================================================= +use jp_pietc, only: u0 +implicit none +real(dp),dimension(:),intent(IN):: a +real(dp),dimension(size(a)) :: b +real(dp) :: s +s=absv_d(a); if(s==u0)then; b=u0;else;b=a/s;endif +end function normalized_d + +!============================================================================= +function orthogonalized_s(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(sp),dimension(:),intent(in):: u,a +real(sp),dimension(size(u)) :: b +real(sp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_s +!============================================================================= +function orthogonalized_d(u,a)result(b)! [orthogonalized] +!============================================================================= +implicit none +real(dp),dimension(:),intent(in):: u,a +real(dp),dimension(size(u)) :: b +real(dp) :: s +! Note: this routine assumes u is already normalized +s=dot_product(u,a); b=a-u*s +end function orthogonalized_d + +!============================================================================= +function cross_product_s(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(in):: a,b +real(sp),dimension(3) :: c +c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1) +end function cross_product_s +!============================================================================= +function cross_product_d(a,b)result(c)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(in):: a,b +real(dp),dimension(3) :: c +c(1)=a(2)*b(3)-a(3)*b(2); c(2)=a(3)*b(1)-a(1)*b(3); c(3)=a(1)*b(2)-a(2)*b(1) +end function cross_product_d +!============================================================================= +function triple_cross_product_s(u,v,w)result(x)! [cross_product] +!============================================================================= +! Deliver the triple-cross-product, x, of the +! three 4-vectors, u, v, w, with the sign convention +! that ordered, {u,v,w,x} form a right-handed quartet +! in the generic case (determinant >= 0). +!============================================================================= +implicit none +real(sp),dimension(4),intent(in ):: u,v,w +real(sp),dimension(4) :: x +!----------------------------------------------------------------------------- +real(sp):: uv12,uv13,uv14,uv23,uv24,uv34 +!============================================================================= +uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1) + uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2) + uv34=u(3)*v(4)-u(4)*v(3) +x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2) +x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1) +x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1) +x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1) +end function triple_cross_product_s +!============================================================================= +function triple_cross_product_d(u,v,w)result(x)! [cross_product] +!============================================================================= +implicit none +real(dp),dimension(4),intent(in ):: u,v,w +real(dp),dimension(4) :: x +!----------------------------------------------------------------------------- +real(dp):: uv12,uv13,uv14,uv23,uv24,uv34 +!============================================================================= +uv12=u(1)*v(2)-u(2)*v(1); uv13=u(1)*v(3)-u(3)*v(1); uv14=u(1)*v(4)-u(4)*v(1) + uv23=u(2)*v(3)-u(3)*v(2); uv24=u(2)*v(4)-u(4)*v(2) + uv34=u(3)*v(4)-u(4)*v(3) +x(1)=-uv23*w(4)+uv24*w(3)-uv34*w(2) +x(2)= uv13*w(4)-uv14*w(3) +uv34*w(1) +x(3)=-uv12*w(4) +uv14*w(2)-uv24*w(1) +x(4)= uv12*w(3)-uv13*w(2)+uv23*w(1) +end function triple_cross_product_d + +!============================================================================= +function outer_product_s(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(sp),dimension(:), intent(in ):: a +real(sp),dimension(:), intent(in ):: b +real(sp),DIMENSION(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_s +!============================================================================= +function outer_product_d(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +real(dp),dimension(:), intent(in ):: a +real(dp),dimension(:), intent(in ):: b +real(dp),dimension(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_d +!============================================================================= +function outer_product_i(a,b)result(c)! [outer_product] +!============================================================================= +implicit none +integer(spi),dimension(:), intent(in ):: a +integer(spi),dimension(:), intent(in ):: b +integer(spi),dimension(size(a),size(b)):: c +integer(spi) :: nb,i +nb=size(b) +do i=1,nb; c(:,i)=a*b(i); enddo +end function outer_product_i + +!============================================================================= +function triple_product_s(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(sp),dimension(3),intent(IN ):: a,b,c +real(sp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_s +!============================================================================= +function triple_product_d(a,b,c)result(tripleproduct)! [triple_product] +!============================================================================= +implicit none +real(dp),dimension(3),intent(IN ):: a,b,c +real(dp) :: tripleproduct +tripleproduct=dot_product( cross_product(a,b),c ) +end function triple_product_d + +!============================================================================= +function det_s(a)result(det)! [det] +!============================================================================= +use jp_pietc_s, only: u0 +implicit none +real(sp),dimension(:,:),intent(IN ) :: a +real(sp) :: det +real(sp),dimension(size(a,1),size(a,1)):: b +integer(spi) :: n,nrank +n=size(a,1) +if(n==3)then + det=triple_product(a(:,1),a(:,2),a(:,3)) +else + call gram(a,b,nrank,det) + if(nranku0 +implicit none +real(sp),dimension(3),intent(IN ):: v1,v2,v3 +real(sp) :: area +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp) :: s123,a1,a2,b,d1,d2,d3 +real(sp),dimension(3) :: u0,u1,u2,u3,x,y +!============================================================================= +area=zero +u1=normalized(v1); u2=normalized(v2); u3=normalized(v3) +s123=triple_product(u1,u2,u3) +if(s123==zero)return + +d1=dot_product(u3-u2,u3-u2) +d2=dot_product(u1-u3,u1-u3) +d3=dot_product(u2-u1,u2-u1) + +! Triangle that is not degenerate. Cyclically permute, so side 3 is longest: +if(d3u0 +implicit none +real(dp),dimension(3),intent(IN ):: v1,v2,v3 +real(dp) :: area +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp) :: s123,a1,a2,b,d1,d2,d3 +real(dp),dimension(3) :: u0,u1,u2,u3,x,y +!============================================================================= +area=zero +u1=normalized(v1); u2=normalized(v2); u3=normalized(v3) +s123=triple_product(u1,u2,u3) +if(s123==zero)return + +d1=dot_product(u3-u2,u3-u2) +d2=dot_product(u1-u3,u1-u3) +d3=dot_product(u2-u1,u2-u1) + +! Triangle that is not degenerate. Cyclically permute, so side 3 is longest: +if(d3nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)nrank)exit + ab(k:m,k:n)=matmul( transpose(a(:,k:m)),b(:,k:n) ) + ii =maxloc( abs( ab(k:m,k:n)) )+k-1 + val=maxval( abs( ab(k:m,k:n)) ) + if(val<=vcrit)then + nrank=k-1 + exit + endif + i=ii(1) + j=ii(2) + tv=b(:,j) + b(:,j)=-b(:,k) + b(:,k)=tv + tv=a(:,i) + a(:,i)=-a(:,k) + a(:,k)=tv + w(k:n)=matmul( transpose(b(:,k:n)),tv ) + b(:,k)=matmul(b(:,k:n),w(k:n) ) + s=dot_product(b(:,k),b(:,k)) + s=sqrt(s) + if(w(k)u0)then + ldet=ldet+log(s) + else + detsign=0 + endif + + b(:,k)=b(:,k)/s + do l=k,n + do j=l+1,n + s=dot_product(b(:,l),b(:,j)) + b(:,j)=normalized( b(:,j)-b(:,l)*s ) + enddo + enddo +enddo +end subroutine graml_d + +!============================================================================= +subroutine plaingram_s(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +use jp_pietc_s, only: u0 +implicit none +real(sp),dimension(:,:),intent(INOUT) :: b +integer(spi), intent( OUT) :: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(sp),parameter :: crit=1.e-5_sp +real(sp) :: val,vcrit +integer(spi) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==0)then + b=u0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=u0 + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_s + +!============================================================================= +subroutine plaingram_d(b,nrank)! [gram] +!============================================================================= +! A "plain" (unpivoted) version of Gram-Schmidt, for square matrices only. +use jp_pietc, only: u0 +implicit none +real(dp),dimension(:,:),intent(INOUT):: b +integer(spi), intent( OUT):: nrank +!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +real(dp),parameter:: crit=1.e-9_dp +real(dp) :: val,vcrit +integer(spi) :: j,k,n +!============================================================================= +n=size(b,1); if(n/=size(b,2))stop 'In gram; matrix needs to be square' +val=maxval(abs(b)) +nrank=0 +if(val==u0)then + b=u0 + return +endif +vcrit=val*crit +do k=1,n + val=sqrt(dot_product(b(:,k),b(:,k))) + if(val<=vcrit)then + b(:,k:n)=u0 + return + endif + b(:,k)=b(:,k)/val + nrank=k + do j=k+1,n + b(:,j)=b(:,j)-b(:,k)*dot_product(b(:,k),b(:,j)) + enddo +enddo +end subroutine plaingram_d + +!============================================================================= +subroutine rowgram(m,n,a,ipiv,tt,b,rank)! [gram] +!============================================================================= +! Without changing (tall) rectangular input matrix a, perform pivoted gram- +! Schmidt operations to orthogonalize the rows, until rows that remain become +! negligible. Record the pivoting sequence in ipiv, and the row-normalization +! in tt(j,j) and the row-orthogonalization in tt(i,j), for i>j. Note that +! tt(i,j)=0 for i=n please' +nepss=n*epss +rank=n +aa=a +tt=u0 +do ii=1,n + +! At this stage, all rows less than ii are already orthonormalized and are +! orthogonal to all rows at and beyond ii. Find the norms of these lower +! rows and pivot the largest of them into position ii: + maxp=u0 + maxi=ii + do i=ii,m + p(i)=dot_product(aa(i,:),aa(i,:)) + if(p(i)>maxp)then + maxp=p(i) + maxi=i + endif + enddo + if(maxpu0,one=>u1,two=>u2 +implicit none +real(dp),dimension(3,3),intent(IN ):: rot +real(dp),dimension(0:3),intent(OUT):: q +!------------------------------------------------------------------------------ +real(dp),dimension(3,3) :: t1,t2 +real(dp),dimension(3) :: u1,u2 +real(dp) :: gamma,gammah,s,ss +integer(spi) :: i,j +integer(spi),dimension(1):: ii +!============================================================================== +! construct the orthogonal matrix, t1, whose third row is the rotation axis +! of rot: +t1=rot; do i=1,3; t1(i,i)=t1(i,i)-1; u1(i)=dot_product(t1(i,:),t1(i,:)); enddo +ii=maxloc(u1); j=ii(1); ss=u1(j) +if(ss<1.e-16_dp)then + q=zero; q(0)=one; return +endif +t1(j,:)=t1(j,:)/sqrt(ss) +if(j/=1)then + u2 =t1(1,:) + t1(1,:)=t1(j,:) + t1(j,:)=u2 +endif +do i=2,3 + t1(i,:)=t1(i,:)-dot_product(t1(1,:),t1(i,:))*t1(1,:) + u1(i)=dot_product(t1(i,:),t1(i,:)) +enddo +if(u1(3)>u1(2))then + j=3 +else + j=2 +endif +ss=u1(j) +if(ss==zero)stop 'In rotov; invalid rot' +if(j/=2)t1(2,:)=t1(3,:) +t1(2,:)=t1(2,:)/sqrt(ss) + +! Form t1(3,:) as the cross product of t1(1,:) and t1(2,:) +t1(3,1)=t1(1,2)*t1(2,3)-t1(1,3)*t1(2,2) +t1(3,2)=t1(1,3)*t1(2,1)-t1(1,1)*t1(2,3) +t1(3,3)=t1(1,1)*t1(2,2)-t1(1,2)*t1(2,1) + +! Project rot into the frame whose axes are the rows of t1: +t2=matmul(t1,matmul(rot,transpose(t1))) + +! Obtain the rotation angle, gamma, implied by rot, and gammah=gamma/2: +gamma=atan2(t2(2,1),t2(1,1)); gammah=gamma/two + +! Hence deduce coefficients (in the form of a real 4-vector) of one of the two +! possible equivalent spinors: +s=sin(gammah) +q(0)=cos(gammah) +q(1:3)=t1(3,:)*s +end subroutine rottoq + +!============================================================================== +subroutine qtorot(q,rot)! [qtorot] +!============================================================================== +! Go from quaternion to rotation matrix representations +!============================================================================== +implicit none +real(dp),dimension(0:3),intent(IN ):: q +real(dp),dimension(3,3),intent(OUT):: rot +!============================================================================= +call setem(q(0),q(1),q(2),q(3),rot) +end subroutine qtorot + +!============================================================================= +subroutine axtoq(v,q)! [axtoq] +!============================================================================= +! Go from an axial 3-vector to its equivalent quaternion +!============================================================================= +implicit none +real(dp),dimension(3), intent(in ):: v +real(dp),dimension(0:3),intent(out):: q +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call axtorot(v,rot) +call rottoq(rot,q) +end subroutine axtoq + +!============================================================================= +subroutine qtoax(q,v)! [qtoax] +!============================================================================= +! Go from quaternion to axial 3-vector +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(in ):: q +real(dp),dimension(3), intent(out):: v +!----------------------------------------------------------------------------- +real(dp),dimension(3,3):: rot +!============================================================================= +call qtorot(q,rot) +call rottoax(rot,v) +end subroutine qtoax + +!============================================================================= +subroutine setem(c,d,e,g,r)! [setem] +!============================================================================= +implicit none +real(dp), intent(IN ):: c,d,e,g +real(dp),dimension(3,3),intent(OUT):: r +!----------------------------------------------------------------------------- +real(dp):: cc,dd,ee,gg,de,dg,eg,dc,ec,gc +!============================================================================= +cc=c*c; dd=d*d; ee=e*e; gg=g*g +de=d*e; dg=d*g; eg=e*g +dc=d*c; ec=e*c; gc=g*c +r(1,1)=cc+dd-ee-gg; r(2,2)=cc-dd+ee-gg; r(3,3)=cc-dd-ee+gg +r(2,3)=2*(eg-dc); r(3,1)=2*(dg-ec); r(1,2)=2*(de-gc) +r(3,2)=2*(eg+dc); r(1,3)=2*(dg+ec); r(2,1)=2*(de+gc) +end subroutine setem + +!============================================================================= +function mulqq(a,b)result(c)! [mulqq] +!============================================================================= +! Multiply quaternions, a*b, assuming operation performed from right to left +!============================================================================= +implicit none +real(dp),dimension(0:3),intent(IN ):: a,b +real(dp),dimension(0:3) :: c +!------------------------------------------- +c(0)=a(0)*b(0) -a(1)*b(1) -a(2)*b(2) -a(3)*b(3) +c(1)=a(0)*b(1) +a(1)*b(0) +a(2)*b(3) -a(3)*b(2) +c(2)=a(0)*b(2) +a(2)*b(0) +a(3)*b(1) -a(1)*b(3) +c(3)=a(0)*b(3) +a(3)*b(0) +a(1)*b(2) -a(2)*b(1) +end function mulqq +!============================================================================= +subroutine expmat(n,a,b,detb)! [expmat] +!============================================================================= +! Evaluate the exponential, b, of a matrix, a, of degree n. +! Apply the iterated squaring method, m times, to the approximation to +! exp(a/(2**m)) obtained as a Taylor expansion of degree L +! See Fung, T. C., 2004, Int. J. Numer. Meth. Engng, 59, 1273--1286. +!============================================================================= +use jp_pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n),intent(IN ):: a +real(dp),dimension(n,n),intent(OUT):: b +real(dp), intent(OUT):: detb +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n):: c,p +real(dp) :: t +integer(spi) :: i,m +!============================================================================= +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +b=p +do i=2,L + p=matmul(p,c)/i + b=b+p +enddo +do i=1,m + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +end subroutine expmat + +!============================================================================= +subroutine expmatd(n,a,b,bd,detb,detbd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st derivatives also. +!============================================================================= +use jp_pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2),intent(OUT):: bd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2):: pd,cd +real(dp) :: t +integer(spi) :: i,j,k,m,n1 +!============================================================================= +n1=(n*(n+1))*o2 +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +pd=u0 +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +b=p +bd=pd + +do i=2,L + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd +enddo +do i=1,m + do k=1,n1 + bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=u0; do k=1,n; detbd(k)=detb; enddo +end subroutine expmatd + +!============================================================================= +subroutine expmatdd(n,a,b,bd,bdd,detb,detbd,detbdd)! [expmat] +!============================================================================= +! Like expmat, but for the 1st and 2nd derivatives also. +!============================================================================= +use jp_pietc, only: u0,u1,u2,o2 +implicit none +integer(spi), intent(IN ):: n +real(dp),dimension(n,n), intent(IN ):: a +real(dp),dimension(n,n), intent(OUT):: b +real(dp),dimension(n,n,(n*(n+1))/2), intent(OUT):: bd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2),intent(OUT):: bdd +real(dp), intent(OUT):: detb +real(dp),dimension((n*(n+1))/2), intent(OUT):: detbd +real(dp),dimension((n*(n+1))/2,(n*(n+1))/2), intent(OUT):: detbdd +!----------------------------------------------------------------------------- +integer(spi),parameter :: L=5 +real(dp),dimension(n,n) :: c,p +real(dp),dimension(n,n,(n*(n+1))/2) :: pd,cd +real(dp),dimension(n,n,(n*(n+1))/2,(n*(n+1))/2):: pdd,cdd +real(dp) :: t +integer(spi) :: i,j,k,ki,kj,m,n1 +!============================================================================= +n1=(n*(n+1))/2 +m=10+floor(log(u1+maxval(abs(a)))/log(u2)) +t=o2**m +c=a*t +p=c +pd=u0 +pdd=u0 +do k=1,n + pd(k,k,k)=t +enddo +k=n +do i=1,n-1 + do j=i+1,n + k=k+1 + pd(i,j,k)=t + pd(j,i,k)=t + enddo +enddo +if(k/=n1)stop 'In expmatd; n1 is inconsistent with n' +cd=pd +cdd=u0 +b=p +bd=pd +bdd=u0 + +do i=2,L + do ki=1,n1 + do kj=1,n1 + pdd(:,:,ki,kj)=(matmul(cd(:,:,ki),pd(:,:,kj)) & + + matmul(cd(:,:,kj),pd(:,:,ki)) & + + matmul(c,pdd(:,:,ki,kj)))/i + enddo + enddo + do k=1,n1 + pd(:,:,k)=(matmul(cd(:,:,k),p)+matmul(c,pd(:,:,k)))/i + enddo + p=matmul(c,p)/i + b=b+p + bd=bd+pd + bdd=bdd+pdd +enddo +do i=1,m + do ki=1,n1 + do kj=1,n1 + bdd(:,:,ki,kj)=u2*bdd(:,:,ki,kj) & + +matmul(bdd(:,:,ki,kj),b) & + +matmul(bd(:,:,ki),bd(:,:,kj)) & + +matmul(bd(:,:,kj),bd(:,:,ki)) & + +matmul(b,bdd(:,:,ki,kj)) + enddo + enddo + do k=1,n1 + bd(:,:,k)=2*bd(:,:,k)+matmul(bd(:,:,k),b)+matmul(b,bd(:,:,k)) + enddo + b=b*u2+matmul(b,b) +enddo +do i=1,n + b(i,i)=b(i,i)+u1 +enddo +detb=u0; do i=1,n; detb=detb+a(i,i); enddo; detb=exp(detb) +detbd=u0; do k=1,n; detbd(k)=detb; enddo +detbdd=u0; do ki=1,n; do kj=1,n; detbdd(ki,kj)=detb; enddo; enddo +end subroutine expmatdd + +!============================================================================= +subroutine zntay(n,z,zn)! [zntay] +!============================================================================= +use jp_pietc, only: u2 +implicit none +integer(spi), intent(IN ):: n +real(dp), intent(IN ):: z +real(dp), intent(OUT):: zn +!----------------------------------------------------------------------------- +integer(spi),parameter:: ni=100 +real(dp),parameter :: eps0=1.e-16_dp +integer(spi) :: i,i2,n2 +real(dp) :: t,eps,z2 +!============================================================================= +z2=z*u2 +n2=n*2 +t=1 +do i=1,n + t=t/(i*2-1) +enddo +eps=t*eps0 +zn=t +do i=1,ni + i2=i*2 + t=t*z2/(i2*(i2+n2-1)) + zn=zn+t + if(abs(t)u0)then + zn=cosh(rz2) + znd=sinh(rz2)/rz2 + zndd=(zn-znd)/z2 + znddd=(znd-u3*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=(znd-i2p3*zndd)/z2 + enddo + else + zn=cos(rz2) + znd=sin(rz2)/rz2 + zndd=-(zn-znd)/z2 + znddd=-(znd-u3*zndd)/z2 + do i=1,n + i2p3=i*2+3 + zn=znd + znd=zndd + zndd=znddd + znddd=-(znd-i2p3*zndd)/z2 + enddo + endif +endif +end subroutine znfun + +!============================================================================= +! Utility code for various Mobius transformations. If aa1,bb1,cc1,dd1 are +! the coefficients for one transformation, and aa2,bb2,cc2,dd2 are the +! coefficients for a second one, then the coefficients for the mapping +! of a test point, zz, by aa1 etc to zw, followed by a mapping of zw, by +! aa2 etc to zv, is equivalent to a single mapping zz-->zv by the transformatn +! with coefficients aa3,bb3,cc3,dd3, such that, as 2*2 complex matrices: +! +! [ aa3, bb3 ] [ aa2, bb2 ] [ aa1, bb1 ] +! [ ] = [ ] * [ ] +! [ cc3, dd3 ] [ cc2, dd2 ] [ cc1, dd1 ] . +! +! Note that the determinant of these matrices is always +1 +! +!============================================================================= +subroutine ctoz(v, z,infz)! [ctoz] +!============================================================================= +use jp_pietc, only: u0,u1 +implicit none +real(dp),dimension(3),intent(IN ):: v +complex(dpc), intent(OUT):: z +logical, intent(OUT):: infz +!----------------------------------------------------------------------------- +real(dp) :: rr,zzpi +!============================================================================= +infz=.false. +z=cmplx(v(1),v(2),dpc) +if(v(3)>u0)then + zzpi=u1/(u1+v(3)) +else + rr=v(1)**2+v(2)**2 + infz=(rr==u0); if(infz)return ! <- The point is mapped to infinity (90S) + zzpi=(u1-v(3))/rr +endif +z=z*zzpi +end subroutine ctoz + +!============================================================================= +subroutine ztoc(z,infz, v)! [ztoc] +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3),intent(OUT):: v +!----------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp,two=2_dp +real(dp) :: r,q,rs,rsc,rsbi +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +v(1)=two*rsbi*r +v(2)=two*rsbi*q +v(3)=rsc*rsbi +end subroutine ztoc + +!============================================================================= +subroutine ztocd(z,infz, v,vd)! [ztoc] +!============================================================================= +! The convention adopted for the complex derivative is that, for a complex +! infinitesimal map displacement, delta_z, the corresponding infinitesimal +! change of cartesian vector position is delta_v given by: +! delta_v = Real(vd*delta_z). +! Thus, by a kind of Cauchy-Riemann relation, Imag(vd)=v CROSS Real(vd). +! THE DERIVATIVE FOR THE IDEAL POINT AT INFINITY HAS NOT BEEN CODED YET!!! +!============================================================================= +implicit none +complex(dpc), intent(IN ):: z +logical, intent(IN ):: infz +real(dp),dimension(3), intent(OUT):: v +complex(dpc),dimension(3),intent(OUT):: vd +!----------------------------------------------------------------------------- +real(dp),parameter :: zero=0_dp,one=1_dp,two=2_dp,four=4_dp +real(dp) :: r,q,rs,rsc,rsbi,rsbis +real(dp),dimension(3):: u1,u2 +integer(spi) :: i +!============================================================================= +if(infz)then; v=(/zero,zero,-one/); return; endif +r=real(z); q=aimag(z); rs=r*r+q*q +rsc=one-rs +rsbi=one/(one+rs) +rsbis=rsbi**2 +v(1)=two*rsbi*r +v(2)=two*rsbi*q +v(3)=rsc*rsbi +u1(1)=two*(one+q*q-r*r)*rsbis +u1(2)=-four*r*q*rsbis +u1(3)=-four*r*rsbis +u2=cross_product(v,u1) +do i=1,3 + vd(i)=cmplx(u1(i),-u2(i),dpc) +enddo +end subroutine ztocd + +!============================================================================ +subroutine setmobius(xc0,xc1,xc2, aa,bb,cc,dd)! [setmobius] +!============================================================================ +! Find the Mobius transformation complex coefficients, aa,bb,cc,dd, +! with aa*dd-bb*cc=1, for a standard (north-)polar stereographic transformation +! that takes cartesian point, xc0 to the north pole, xc1 to (lat=0,lon=0), +! xc2 to the south pole (=complex infinity). +!============================================================================ +implicit none +real(dp),dimension(3),intent(IN ):: xc0,xc1,xc2 +complex(dpc), intent(OUT):: aa,bb,cc,dd +!---------------------------------------------------------------------------- +real(dp),parameter:: zero=0_dp,one=1_dp +logical :: infz0,infz1,infz2 +complex(dpc) :: z0,z1,z2,z02,z10,z21 +!============================================================================ +call ctoz(xc0,z0,infz0) +call ctoz(xc1,z1,infz1) +call ctoz(xc2,z2,infz2) +z21=z2-z1 +z02=z0-z2 +z10=z1-z0 + +if( (z0==z1.and.infz0.eqv.infz1).or.& + (z1==z2.and.infz1.eqv.infz2).or.& + (z2==z0.and.infz2.eqv.infz0)) & + stop 'In setmobius; anchor points must be distinct' + +if(infz2 .or. (.not.infz0 .and. abs(z0)= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if +! +! Assign received values from NORTH and SOUTH +! +! From SOUTH + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +!---------------------------------------------------------------------- +! +! SEND extended boundaries toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + + +! +! Assign received values from EAST and WEST +! + +! From west + + if(lwest) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_2d_gh & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + ndatax = km_in*(jmax+2*nby)*nbx + + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +! +! Assign received values from NORTH and SOUTH +! + + +! From south + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! +! SEND extended boundaries to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_2d_g1 & +!*********************************************************************** +! ! +! Adjoint of side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions, including ! +! values at the edges of the subdomains and assuming mirror boundary ! +! conditions just for generation 1 ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + + g_ind=1 +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if + +! +! Assign received halos from WEST and EAST to interrior of domains +! + +! From west + + if(lwest) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +! +! SEND boundaries SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + +! +! RECEIVE boundaries from NORTH and SOUTH +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! ASSIGN received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + deallocate( rBuf_W, stat = iderr) + deallocate( rBuf_E, stat = iderr) + deallocate( rBuf_S, stat = iderr) + deallocate( rBuf_N, stat = iderr) + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + + +!----------------------------------------------------------------------- +endsubroutine bocoT_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_2d_gh & +!*********************************************************************** +! ! +! Supply n-lines inside of domains, including edges, with halos from ! +! the surrounding domains. Assume mirror boundary conditions at the ! +! boundaries of the domain. For high multigrid generations. ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby + +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + deallocate( rBuf_W, stat = iderr) + deallocate( rBuf_E, stat = iderr) + deallocate( rBuf_S, stat = iderr) + deallocate( rBuf_N, stat = iderr) + +! DEALLOCATE sBufferes + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoT_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_3d_g1 & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for generation 1 ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz +real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind,g +logical l_sidesend +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit communications to generation one +! + g_ind=1 + + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + +!----------------------------------------------------------------------- + ndatay = km3_in*imax*nby*Lm + ndatax = km3_in*(jmax+2*nby)*nbx*Lm_in + + +! +! SEND boundaries toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_S(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L) + enddo + enddo + enddo + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=rBuf_N(:,i,j,L) + enddo + enddo + enddo + + endif + +! From south + + if(lsouth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=W(:,i,nby+1-j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=rBuf_S(:,i,j,L) + enddo + enddo + enddo + + endif + +! +! SEND extended boundaries toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries WEST and EAST +! + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! +! Assign received values from EAST and WEST +! +! From west + + if(lwest) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= W(:,nbx+1-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= rBuf_W(:,i,j,L) + enddo + enddo + enddo + + + endif + +! From east + + if(least) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=W(:,imax-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=rBuf_E(:,i,j,L) + enddo + enddo + enddo + + endif + +!------------------------------------------------------------------ +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + +!----------------------------------------------------------------------- +endsubroutine boco_3d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_3d_gh & +!**********************************************************************! + +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max +real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km3_in*imax*nby*Lm + ndatax = km3_in*(jmax+2*nby)*nbx*Lm + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_S(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax-nby+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from SOUTH and NORTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km3_in,1:imax,nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +!TEST + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if +!TEST + +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=W(:,i,jmax+1-j,L) + enddo + enddo + enddo + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax+j,L)=rBuf_N(:,i,j,L) + enddo + enddo + enddo + + endif + +! From south + + if(lsouth) then + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=W(:,i,nby+1-j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1,nby + do i=1,imax + W(:,i,-nby+j,L)=rBuf_S(:,i,j,L) + enddo + enddo + enddo + + endif + +!TEST + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif +!TEST + + +! +! SEND extended boundaries to WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km3_in,nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! +! Deallocate send bufferes from EAST and WEST +! + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + +! +! Assign received values from WEST and EAST +! +! From west + + if(lwest) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= W(:,nbx+1-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j,L)= rBuf_W(:,i,j,L) + enddo + enddo + enddo + + + endif + +! From east + + if(least) then + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=W(:,imax+1-i,j,L) + end do + end do + end do + + else + + do L=1,Lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j,L)=rBuf_E(:,i,j,L) + enddo + enddo + enddo + + endif + +! +! Set up mirror b.c. at the bottom and top of domain +! + do L=1,nbz + W(:,:,:,1-L )=W(:,:,:, 1+L) + W(:,:,:,LM+L)=W(:,:,:,LM-L) + end do + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_3d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_3d_g1 & +!*********************************************************************** +! * +! Supply n-lines inside of domains, including edges, with halos from * +! the surrounding domains. Assume mirror boundary conditions at the * +! boundaries of the domain * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz +real(r_kind), dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- + +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + g_ind=1 + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + imax = im + jmax = jm + +!---------------------------------------------------------------------- + ndatax =km3_in*(jmax+2*nby)*nbx *Lm_in + ndatay =km3_in*imax*nby *Lm_in + +! +! SEND extended halos toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if +! +! RECEIVE extended halos from EAST and WEST +! +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km3_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if +! +! Assign received extended halos from WEST and EAST to interior of domains +! + +! From west + + if(lwest) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+W(:,1-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+rBuf_W(:,i,j,L) + end do + end do + end do + endif + +! From east + + if(least) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+W(:,imax+nbx-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+rBuf_E(:,i,j,L) + end do + end do + end do + endif + +! +! Send halos SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + + +! +! RECEIVE boundaries from NORTH and SOUTH +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km3_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+W(:,i,1-j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+rBuf_S(:,i,j,L) + end do + end do + end do + endif + +! From north + + if(lnorth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+W(:,i,jmax+nby-j,L) + enddo + enddo + enddo + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+rBuf_N(:,i,j,L) + enddo + enddo + enddo + endif + +!---------------------------------------------------------------------- +! +! Set up mirror b.c. at the bottom and top of domain +! + do L=1,nbz + W(:,:,:,1+L )=W(:,:,:, 1+L)+W(:,:,:, 1-L) + W(:,:,:,LM-L)=W(:,:,:,LM-L)+W(:,:,:,LM+L) + end do + + +!---------------------------------------------------------------------- +! +! DEALLOCATE sBufferes +! + + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + + +!----------------------------------------------------------------------- +endsubroutine bocoT_3d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_3d_gh & +!*********************************************************************** +! * +! Supply n-lines inside of domains, including edges, with halos from * +! the surrounding domains. Assume mirror boundary conditions at the * +! boundaries of the domain * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz) & + ,intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx *Lm_in + ndatay =km_in*imax*nby *Lm_in + +! +! SEND extended halos toward WEST and EAST +! +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j,L) = W(:,-nbx+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j,L) = W(:,imax+i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if + +! +! Assign received extended halos from WEST and EAST +! + +! From west + + if(lwest) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+W(:,1-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j,L)= W(:,i,j,L)+rBuf_W(:,i,j,L) + end do + end do + end do + endif + +! From east + + if(least) then + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+W(:,imax+1+nbx-i,j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j,L)= W(:,imax-nbx+i,j,L)+rBuf_E(:,i,j,L) + end do + end do + end do + endif + +! +! SEND halos toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby,L) = W(:,i,j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + + do L=Lm_in,1,-1 + do j=1,nby + do i=1,imax + sBuf_N(:,i,j,L)=W(:,i,jmax+j,L) + enddo + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby,1:Lm_in), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + + +!----------------------------------------------------------------------- +! +! Assign received halos from SOUTH and NORTH +! + + if(lsouth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+W(:,i,1-j,L) + end do + end do + end do + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,j,L)= W(:,i,j,L)+rBuf_S(:,i,j,L) + end do + end do + end do + endif + +! From north + + if(lnorth) then + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+W(:,i,jmax+1+nby-j,L) + enddo + enddo + enddo + else + do L=1,lm_in + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j,L)= W(:,i,jmax-nby+j,L)+rBuf_N(:,i,j,L) + enddo + enddo + enddo + endif + + +! +! Set up mirror b.c. at the bottom and top of domain +! + do L=1,nbz + W(:,:,:,1+L )=W(:,:,:, 1+L)+W(:,:,:, 1-L) + W(:,:,:,LM-L)=W(:,:,:,LM-L)+W(:,:,:,LM+L) + end do + + +!----------------------------------------------------------------------- +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoT_3d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_all_g1 & +!*********************************************************************** +! ! +! Upsend data from generation one to generation two ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,Harray,Warray,km_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray +real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe + +integer(i_kind):: mygen_dn,mygen_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up +integer(i_kind):: itarg_up +integer:: g_ind +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" + +!----------------------------------------------------------------------- + mygen_dn=1 + mygen_up=2 +! +! Define generational flags +! + g_ind=1 + + lsendup_sw=Flsendup_sw(g_ind) + lsendup_se=Flsendup_se(g_ind) + lsendup_nw=Flsendup_nw(g_ind) + lsendup_ne=Flsendup_ne(g_ind) + + + itarg_up=Fitarg_up(g_ind) + + +!----------------------------------------------------------------------- + + if(my_hgen==mygen_up) then + Warray(:,:,:) = 0.0d0 + endif + + ndata =km_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_sw >= 0 ) then + + nebpe = itargdn_sw + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + Warray(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_se >= 0 ) then + + nebpe = itargdn_se + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + Warray(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_nw >= 0 ) then + + nebpe = itargdn_nw + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + Warray(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then + + nebpe = itargdn_ne + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + Warray(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_all_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_all_gh & +!*********************************************************************** +! * +! Upsend data from one grid generation to another * +! (Just for high grid generations) * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,Harray,Warray,km_in,mygen_dn,mygen_up) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray +real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray +integer(i_kind),intent(in):: mygen_dn,mygen_up +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe + +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne,flag_up +integer(i_kind):: itarg_up +integer:: g_ind +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" + +!----------------------------------------------------------------------- +! +! Define generational flags +! + + g_ind=2 + + lsendup_sw=Flsendup_sw(g_ind).and.(my_hgen==mygen_dn) + lsendup_se=Flsendup_se(g_ind).and.(my_hgen==mygen_dn) + lsendup_nw=Flsendup_nw(g_ind).and.(my_hgen==mygen_dn) + lsendup_ne=Flsendup_ne(g_ind).and.(my_hgen==mygen_dn) + + itarg_up=Fitarg_up(g_ind) + + +!----------------------------------------------------------------------- + + if(my_hgen==mygen_up) then + Warray(:,:,:)=0.0d0 + endif + + ndata =km_in*imL*jmL + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + + end if + +! +! --- Receive SW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_sw >= 0 ) then + + nebpe = itargdn_sw + + allocate( rBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,i,j)=Rbuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + end if + +! +! --- Receive SE portion of data at higher generation + + + if( my_hgen==mygen_up .and. itargdn_se >= 0 ) then + nebpe = itargdn_se + + + allocate( rBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,imL+i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + endif + + +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + + end if + +! +! --- Receive NW portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_nw >= 0 ) then + nebpe = itargdn_nw + + + allocate( rBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,i,jmL+j)=rBuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + end if + +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Harray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + end if + +! +! --- Receive NE portion of data at higher generation +! + + if( my_hgen==mygen_up .and. itargdn_ne >= 0 ) then + nebpe = itargdn_ne + + allocate( rBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + Warray(:,imL+i,jmL+j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + endif + +!----------------------------------------------------------------------- +endsubroutine upsend_all_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_all_gh & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,Warray,Harray,km_in,mygen_up,mygen_dn) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray +integer, intent(in):: mygen_up,mygen_dn +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe + +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +integer(i_kind):: itarg_up +integer(i_kind):: g_ind +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + Harray(:,:,:) = 0.0d0 +! +! Define generational flags +! + + g_ind=2 + lsendup_sw=Flsendup_sw(g_ind).and.(my_hgen==mygen_dn) + lsendup_se=Flsendup_se(g_ind).and.(my_hgen==mygen_dn) + lsendup_nw=Flsendup_nw(g_ind).and.(my_hgen==mygen_dn) + lsendup_ne=Flsendup_ne(g_ind).and.(my_hgen==mygen_dn) + + itarg_up=Fitarg_up(g_ind) + + ndata =km_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + + if(my_hgen==mygen_up .and. itargdn_sw >= 0 ) then + nebpe = itargdn_sw + + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Warray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + + endif +! +! --- Receive SW portion of data at lower generation + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(my_hgen==mygen_up .and. itargdn_se >= 0 ) then + nebpe = itargdn_se + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Warray(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if(my_hgen==mygen_up .and. itargdn_nw >= 0 ) then + nebpe = itargdn_nw + + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Warray(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + + endif +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(my_hgen==mygen_up .and. itargdn_ne >= 0 ) then + nebpe = itargdn_ne + + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + + endif +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( rBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_all_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_all_g2 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! * +! - offset version - * +! * +!*********************************************************************** +(this,Warray,Harray,km_in) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray +real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE + +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe + +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +integer:: mygen_up,mygen_dn +integer(i_kind):: itarg_up +integer(i_kind):: g_ind +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Define generational flags +! + mygen_up=2 + mygen_dn=1 + + g_ind=1 + lsendup_sw=Flsendup_sw(g_ind) + lsendup_se=Flsendup_se(g_ind) + lsendup_nw=Flsendup_nw(g_ind) + lsendup_ne=Flsendup_ne(g_ind) + + itarg_up=Fitarg_up(g_ind) + + + ndata =km_in*imL*jmL + + +! +! Send data down to generation 1 +! +LSEND: if(my_hgen==mygen_up) then +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + nebpe = itargdn_sw + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = Warray(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Warray(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + nebpe = itargdn_se + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = Warray(:,imL+i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Warray(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + endif + +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + nebpe = itargdn_nw + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = Warray(:,i,jmL+j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Warray(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + endif + +! +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + nebpe = itargdn_ne + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Warray(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + endif + + + endif LSEND + +! +! --- Receive SW portion of data at lower generation +! + + if( lsendup_sw .and. mype /= itarg_up ) then + + nebpe = itarg_up + + + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + + else & + +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se .and. mype /= itarg_up) then + + nebpe = itarg_up + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + + else & + + +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw .and. mype /= itarg_up) then + + nebpe = itarg_up + + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + else & + + +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne .and. mype /= itarg_up) then + nebpe = itarg_up + + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + + end if + +! +! Assign received and prescribed values +! + if( lsendup_sw ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + else & + if( lsendup_se ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_SE(:,i,j) + enddo + enddo + + else & + if( lsendup_nw ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_NW(:,i,j) + enddo + enddo + + else & + if( lsendup_ne ) then + + do j=1,jmL + do i=1,imL + Harray(:,i,j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine downsend_all_g2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocox_2d_g1 & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nbx lines of halos in x direction assuming mirror boundary ! +! conditions at the end of domain. Version for generation 1 ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W + +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical:: lwest,least + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax +integer(i_kind) g_ind,g +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + g_ind = 1 + + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + + imax = im_in + jmax = jm_in + + +!----------------------------------------------------------------------- + ndatax = km_in*jmax*nbx + +!---------------------------------------------------------------------- +! +! SEND extended boundaries toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + + +! +! Assign received values from EAST and WEST +! + +! From west + + if(lwest) then + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocox_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocox_2d_gh & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nbx lines of halos in x direction assuming mirror boundary ! +! conditions at the end of domain. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W + +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm + endif + + +!----------------------------------------------------------------------- + ndatax = km_in*jmax*nbx + +! +! SEND halos to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=W(:,imax-i,j) + end do + end do + + else + + do j=1,jmax + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocox_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoy_2d_g1 & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nby lines of halos in y direction assuming mirror boundary ! +! conditions at the end of domain. Version for generation 1 ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S + +integer(i_kind) itarg_n,itarg_s,imax,jmax +logical:: lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +integer(i_kind) g_ind,g +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + g_ind = 1 + + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + + +! +! SEND boundaries toward SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! From SOUTH + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoy_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoy_2d_gh & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies nby lines of halos in y direction assuming mirror boundary ! +! conditions at the end of domain. Version for high generations ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S + +integer(i_kind) itarg_n,itarg_s,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +integer(i_kind) g_ind,g +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +! +! Assign received values from NORTH and SOUTH +! + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! From south + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + endif + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoy_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTx_2d_g1 & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nbx lines close to edges of the subdomins from neighboring ! +! halos in x direction assuming mirror boundary conditions ! +! Version for generation 1 ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W + +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical lwest,least + +integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + + g_ind=1 +! +! from mg_domain +! + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + + imax = im_in + jmax = jm_in + + +!---------------------------------------------------------------------- + ndatax =km_in*jmax*nbx + +! +! SEND halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1-nbx,0 + sBuf_W(:,i+nbx,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + + allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + + allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + + end if + +! +! Assign received halos from WEST and EAST to interrior of domains +! + +! From west + + if(lwest) then + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+nbx+1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + endif + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + endif + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + +!----------------------------------------------------------------------- +endsubroutine bocoTx_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTx_2d_gh & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nbx lines close to edges of the subdomins from neighboring ! +! halos in x direction assuming mirror boundary conditions ! +! Version for high generations ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_E,sBuf_W & + ,rBuf_E,rBuf_W +integer(i_kind) itarg_w,itarg_e,imax,jmax +logical lwest,least,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_w = Fitarg_w(g_ind) + itarg_e = Fitarg_e(g_ind) + + lwest = Flwest(g_ind) + least = Fleast(g_ind) + + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*jmax*nbx +! +! SEND halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1-nbx,0 + sBuf_W(:,i+nbx,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + + do j=1,jmax + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,1:nbx,1:jmax), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+nbx+1-i,j) + end do + end do + else + do j=1,jmax + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + +! DEALLOCATE sBufferes + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoTx_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTy_2d_g1 & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nby lines close to edges of the subdomins from neighboring ! +! halos in y direction assuming mirror boundary conditions ! +! Version for generation 1 ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S + +integer(i_kind) itarg_n,itarg_s,imax,jmax +logical lsouth,lnorth + +integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +!----------------------------------------------------------------------- +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +! +! Limit comminications to selected number of generations +! + + g_ind=1 +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + imax = im_in + jmax = jm_in + + +!---------------------------------------------------------------------- + ndatay =km_in*imax*nby + +! +! SEND SOUTH and NORTH halos +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + + end if + +! +! ASSIGN received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+nby+1-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + + +!----------------------------------------------------------------------- +endsubroutine bocoTy_2d_g1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoTy_2d_gh & +!*********************************************************************** +! ! +! Side sending subroutine: ! +! Supplies nby lines close to edges of the subdomins from neighboring ! +! halos in y direction assuming mirror boundary conditions ! +! Version for high generations ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: sBuf_N,sBuf_S & + ,rBuf_N,rBuf_S +integer(i_kind) itarg_n,itarg_s,itarg_e,imax,jmax +logical least,lsouth,lnorth + +integer(i_kind) sHandle(2),rHandle(2),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatay +logical l_sidesend +integer(i_kind) g_ind,g,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + + if(mygen_min <= my_hgen .and. my_hgen <= mygen_max) then + g_ind=2 + g = my_hgen + l_sidesend=.true. + else + l_sidesend=.false. + endif + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n(g_ind) + itarg_s = Fitarg_s(g_ind) + + least = Fleast(g_ind) + lsouth = Flsouth(g_ind) + lnorth = Flnorth(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + + ndatay =km_in*imax*nby +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1-nby,0 + do i=1,imax + sBuf_S(:,i,j+nby) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+nby+1-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! DEALLOCATE sBufferes + + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoTy_2d_gh + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine boco_2d_loc & +!**********************************************************************! +! ! +! Side sending subroutine: ! +! Supplies (nbx,nby) lines of halos in (x,y) directions assuming ! +! mirror boundary conditions. Version for localiztion ! +! ! +! - offset version - ! +! ! +!**********************************************************************! +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g +real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W + +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical:: lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,l,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +integer(i_kind) g_ind +logical l_sidesend +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit communications to selected number of generations +! + + l_sidesend=.true. + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff +! +! from mg_domain +! + itarg_n = Fitarg_n_loc(g) + itarg_s = Fitarg_s_loc(g) + itarg_w = Fitarg_w_loc(g) + itarg_e = Fitarg_e_loc(g) + + lwest = Flwest_loc(g) + least = Fleast_loc(g) + lsouth = Flsouth_loc(g) + lnorth = Flnorth_loc(g) + + +! +! Keep this for now but use only Mod(nxm,8)=Mod(nym,8)=0 +! + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!----------------------------------------------------------------------- + ndatay = km_in*imax*nby + ndatax = km_in*(jmax+2*nby)*nbx + + +! +! SEND boundaries to SOUTH and NORTH +! + +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if +! +! RECEIVE boundaries from NORTH and SOUTH +! + +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( rBuf_N(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( rBuf_S(1:km_in,1:imax,nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + end if + +! +! Assign received values from NORTH and SOUTH +! + + +! From south + + if(lsouth) then + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=W(:,i,nby+1-j) + end do + end do + + else + + do j=1,nby + do i=1,imax + W(:,i,-nby+j)=rBuf_S(:,i,j) + enddo + enddo + + endif + + +! --- from NORTH --- + + if( lnorth) then + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=W(:,i,jmax+1-j) + enddo + enddo + + else + + do j=1,nby + do i=1,imax + W(:,i,jmax+j)=rBuf_N(:,i,j) + enddo + enddo + + endif + +! +! SEND extended boundaries to WEST and EASTH +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended boundaries from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if + +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= W(:,nbx+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,-nbx+i,j)= rBuf_W(:,i,j) + enddo + enddo + + + endif + +! From east + + if(least) then + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=W(:,imax+1-i,j) + end do + end do + + else + + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax+i,j)=rBuf_E(:,i,j) + enddo + enddo + + endif + +!----------------------------------------------------------------------- +! +! DEALLOCATE rBufferes +! + if( itarg_w >= 0 ) then + deallocate( rBuf_W, stat = iderr) + end if + if( itarg_e >= 0 ) then + deallocate( rBuf_E, stat = iderr) + end if + if( itarg_s >= 0 ) then + deallocate( rBuf_S, stat = iderr) + end if + if( itarg_n >= 0 ) then + deallocate( rBuf_N, stat = iderr) + end if + +! +! DEALLOCATE sBufferes +! + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_W, stat = ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_E, stat = ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_S, stat = ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_N, stat = ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine boco_2d_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine bocoT_2d_loc & +!*********************************************************************** +! ! +! Supply n-lines inside of domains, including edges, with halos from ! +! the surrounding domains. Assume mirror boundary conditions at the ! +! boundaries of the domain. Vesrion for localization. ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g +real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W +integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_N,sBuf_E,sBuf_S,sBuf_W & + ,rBuf_N,rBuf_E,rBuf_S,rBuf_W +integer(i_kind) itarg_n,itarg_s,itarg_w,itarg_e,imax,jmax +logical lwest,least,lsouth,lnorth + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,L,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind) ndatax,ndatay +logical l_sidesend +integer(i_kind) g_ind,k +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +! +! Limit comminications to selected number of generations +! + + + g_ind=g + l_sidesend=.true. + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +FILT_GRID: if(l_sidesend) then + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +! +! from mg_domain +! + itarg_n = Fitarg_n_loc(g_ind) + itarg_s = Fitarg_s_loc(g_ind) + itarg_w = Fitarg_w_loc(g_ind) + itarg_e = Fitarg_e_loc(g_ind) + + lwest = Flwest_loc(g_ind) + least = Fleast_loc(g_ind) + lsouth = Flsouth_loc(g_ind) + lnorth = Flnorth_loc(g_ind) + + + if(least) then + imax = Fimax_in(g) + else + imax = im_in ! << Note that is not necesseraly im from + endif ! mg_parameter. Could be also imL >>> + if(lnorth) then + jmax = Fjmax_in(g) + else + jmax = jm_in + endif + + +!---------------------------------------------------------------------- + ndatax =km_in*(jmax+2*nby)*nbx + ndatay =km_in*imax*nby + +! +! SEND extended halos toward WEST and EAST +! + +! --- toward WEST --- + + if( itarg_w >= 0) then + nebpe = itarg_w + + allocate( sBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_W(:,i,j) = W(:,-nbx+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_W, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + + end if + +! --- toward EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( sBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + + do j=1-nby,jmax+nby + do i=1,nbx + sBuf_E(:,i,j) = W(:,imax+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_E, ndatax, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + + end if + +! +! RECEIVE extended halos from EAST and WEST +! + +! --- from EAST --- + + if( itarg_e >= 0 ) then + nebpe = itarg_e + + allocate( rBuf_E(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_E, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + end if + +! --- from WEST --- + + if( itarg_w >= 0 ) then + nebpe = itarg_w + + allocate( rBuf_W(1:km_in,1:nbx,1-nby:jmax+nby), stat = iaerr ) + call MPI_IRECV( rBuf_W, ndatax, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + end if +! +! Assign received values from WEST and EAST +! + +! From west + + if(lwest) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+W(:,1-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,i,j)= W(:,i,j)+rBuf_W(:,i,j) + end do + end do + endif + +! From east + + if(least) then + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+W(:,imax+1+nbx-i,j) + end do + end do + else + do j=1-nby,jmax+nby + do i=1,nbx + W(:,imax-nbx+i,j)= W(:,imax-nbx+i,j)+rBuf_E(:,i,j) + end do + end do + endif + +! +! SEND halos toward SOUTH and NORTH +! +! --- toward SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + allocate( sBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_S(:,i,j) = W(:,i,-nby+j) + enddo + enddo + + call MPI_ISEND( sBuf_S, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + end if + +! --- toward NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + allocate( sBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + + do j=1,nby + do i=1,imax + sBuf_N(:,i,j)=W(:,i,jmax+j) + enddo + enddo + + call MPI_ISEND( sBuf_N, ndatay, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + + end if + +! +! RECEIVE halos from NORTH and SOUTH +! +! +! --- from NORTH --- + + if( itarg_n >= 0 ) then + nebpe = itarg_n + + + allocate( rBuf_N(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_N, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + end if + +! --- from SOUTH --- + + if( itarg_s >= 0 ) then + nebpe = itarg_s + + + allocate( rBuf_S(1:km_in,1:imax,1:nby), stat = iaerr ) + call MPI_IRECV( rBuf_S, ndatay, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + + end if + +! +! Assign received values from SOUTH and NORTH +! + +! From south + + if(lsouth) then + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+W(:,i,1-j) + end do + end do + else + do j=1,nby + do i=1,imax + W(:,i,j)= W(:,i,j)+rBuf_S(:,i,j) + end do + end do + endif + +! From north + + if(lnorth) then + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+W(:,i,jmax+1+nby-j) + enddo + enddo + else + do j=1,nby + do i=1,imax + W(:,i,jmax-nby+j)= W(:,i,jmax-nby+j)+rBuf_N(:,i,j) + enddo + enddo + endif + +!----------------------------------------------------------------------- + +! DEALLOCATE rBufferes + + deallocate( rBuf_W, stat = iderr) + deallocate( rBuf_E, stat = iderr) + deallocate( rBuf_S, stat = iderr) + deallocate( rBuf_N, stat = iderr) + +! DEALLOCATE sBufferes + + if( itarg_w >= 0 ) then + call MPI_WAIT( sHandle(4), istat, ierr ) + end if + if( itarg_e >= 0 ) then + call MPI_WAIT( sHandle(2), istat, ierr ) + end if + if( itarg_s >= 0 ) then + call MPI_WAIT( sHandle(3), istat, ierr ) + end if + if( itarg_n >= 0 ) then + call MPI_WAIT( sHandle(1), istat, ierr ) + end if + + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + + endif FILT_GRID + +!fffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffffff + +!----------------------------------------------------------------------- +endsubroutine bocoT_2d_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_loc_g12 & +!*********************************************************************** +! ! +! Upsend data from generation one to generation two ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,H,km_4_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_4_in,flag +real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(in):: V_in +real(r_kind), dimension(km_4_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: mygen_dn,mygen_up +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + mygen_dn=1 + mygen_up=2 +! +! Define generational flags +! + + itarg_up=Fitargup_loc12(flag) + + lsendup_sw = lsendup_sw_loc + lsendup_se = lsendup_se_loc + lsendup_nw = lsendup_nw_loc + lsendup_ne = lsendup_ne_loc +!----------------------------------------------------------------------- + +!N if(my_hgen==mygen_up) then + H(:,:,:) = 0.0d0 +!N endif + + ndata =km_4_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_sw_loc21 >= 0 ) then + if( itargdn_sw_loc21 >= 0 ) then + + nebpe = itargdn_sw_loc21 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_se_loc21 >= 0 ) then + if( itargdn_se_loc21 >= 0 ) then + + nebpe = itargdn_se_loc21 + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + H(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + +! if( my_hgen==mygen_up .and. itargdn_nw_loc21 >= 0 ) then + if( itargdn_nw_loc21 >= 0 ) then + + nebpe = itargdn_nw_loc21 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_ne_loc21 >= 0 ) then + if( itargdn_ne_loc21 >= 0 ) then + + nebpe = itargdn_ne_loc21 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_loc_g12 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_loc_g23 & +!*********************************************************************** +! ! +! Upsend data from generation three to generation four ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,H,km_16_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_16_in,flag +real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(in):: V_in +real(r_kind), dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: mygen_dn,mygen_up +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + mygen_dn=2 + mygen_up=3 +! +! Define generational flags +! + + itarg_up=Fitargup_loc23(flag) + + lsendup_sw = lsendup_sw_loc + lsendup_se = lsendup_se_loc + lsendup_nw = lsendup_nw_loc + lsendup_ne = lsendup_ne_loc +!----------------------------------------------------------------------- + +!N if(my_hgen==mygen_up) then + H(:,:,:) = 0.0d0 +!N endif + + ndata =km_16_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_sw_loc32 >= 0 ) then + if( itargdn_sw_loc32 >= 0 ) then + + nebpe = itargdn_sw_loc32 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_se_loc32 >= 0 ) then + if( itargdn_se_loc32 >= 0 ) then + + nebpe = itargdn_se_loc32 + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + H(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + +! if( my_hgen==mygen_up .and. itargdn_nw_loc32 >= 0 ) then + if( itargdn_nw_loc32 >= 0 ) then + + nebpe = itargdn_nw_loc32 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_ne_loc32 >= 0 ) then + if( itargdn_ne_loc32 >= 0 ) then + + nebpe = itargdn_ne_loc32 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_loc_g23 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsend_loc_g34 & +!*********************************************************************** +! ! +! Upsend data from generation three to generation four ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,H,km_64_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_64_in,flag +real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(in):: V_in +real(r_kind), dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: mygen_dn,mygen_up +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + mygen_dn=3 + mygen_up=4 +! +! Define generational flags +! + + itarg_up=Fitargup_loc34(flag) + + lsendup_sw = lsendup_sw_loc + lsendup_se = lsendup_se_loc + lsendup_nw = lsendup_nw_loc + lsendup_ne = lsendup_ne_loc +!----------------------------------------------------------------------- + +!N if(my_hgen==mygen_up) then + H(:,:,:) = 0.0d0 +!N endif + + ndata =km_64_in*imL*jmL + +! +! --- Send data to SW portion of processors at higher generation +! + + if( lsendup_sw ) then + + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + + deallocate( sBuf_SW, stat = ierr ) + + endif + + endif +! +! --- Receive SW portion of data at higher generation +! + + if( itargdn_sw_loc43 >= 0 ) then + + nebpe = itargdn_sw_loc43 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,j)=dBuf_SW(:,i,j) + enddo + enddo + + endif + +! +! --- Send data to SE portion of processors at higher generation +! + + if( lsendup_se ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + + deallocate( sBuf_SE, stat = ierr ) + + endif + + end if + +! +! --- Receive SE portion of data at higher generation +! + + if( itargdn_se_loc43 >= 0 ) then + + nebpe = itargdn_se_loc43 + + if(nebpe /= mype) then + + call MPI_IRECV( dBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + endif + do j=1,jmL + do i=1,imL + H(:,imL+i,j)=dBuf_SE(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NW portion of processors at higher generation +! + + if( lsendup_nw ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(3), isend) + + call MPI_WAIT( sHandle(3), istat, ierr ) + + deallocate( sBuf_NW, stat = ierr ) + + end if + + end if + +! +! --- Receive NW portion of data at higher generation +! + +! if( my_hgen==mygen_up .and. itargdn_nw_loc43 >= 0 ) then + if( itargdn_nw_loc43 >= 0 ) then + + nebpe = itargdn_nw_loc43 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,i,jmL+j)=dBuf_NW(:,i,j) + enddo + enddo + + endif +! +! --- Send data to NE portion of processors at higher generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + if(nebpe == mype) then + + do j=1,jmL + do i=1,imL + dBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + else + + allocate( sBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = V_in(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_comp, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + + deallocate( sBuf_NE, stat = ierr ) + + endif + + end if + +! +! --- Receive NE portion of data at higher generation +! + +!N if( my_hgen==mygen_up .and. itargdn_ne_loc43 >= 0 ) then + if( itargdn_ne_loc43 >= 0 ) then + + nebpe = itargdn_ne_loc43 + + if(nebpe /= mype) then + call MPI_IRECV( dBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_comp, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + endif + + do j=1,jmL + do i=1,imL + H(:,imL+i,jmL+j)=dBuf_NE(:,i,j) + enddo + enddo + + endif + + +!----------------------------------------------------------------------- +endsubroutine upsend_loc_g34 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_loc_g43 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,W,Z,km_64_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_64_in,flag +real(r_kind), dimension(km_64_in,1:this%im,1:this%jm),intent(in):: W +real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(out):: Z +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_64_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + Z(:,:,:) = 0.0d0 +! +! Define generational flags +! + + itarg_up=Fitargup_loc34(flag) + + ndata =km_64_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(itargdn_sw_loc43 >= 0) then + + nebpe = itargdn_sw_loc43 + + + allocate( sBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = W(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif + +! +! --- Receive SW portion of data at lower generation + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(itargdn_se_loc43 >= 0) then + + nebpe = itargdn_se_loc43 + + allocate( sBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = W(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if(itargdn_nw_loc43 >= 0) then + + nebpe = itargdn_nw_loc43 + + + allocate( sBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = W(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + endif + +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if(itargdn_ne_loc43 >= 0) then + + nebpe = itargdn_ne_loc43 + + allocate( sBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = W(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + endif + +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( rBuf_NE(1:km_64_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + Z(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_loc_g43 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_loc_g32 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,Z,H,km_16_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_16_in,flag +real(r_kind), dimension(km_16_in,1:this%im,1:this%jm),intent(in):: Z +real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(out):: H +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_16_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + H(:,:,:) = 0.0d0 +! +! Define generational flags +! + + itarg_up=Fitargup_loc23(flag) + + ndata =km_16_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + + if( itargdn_sw_loc32 >= 0 ) then + + nebpe = itargdn_sw_loc32 + + + allocate( sBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = Z(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif + +! +! --- Receive SW portion of data at lower generation + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_se_loc32 >= 0 ) then + + nebpe = itargdn_se_loc32 + + allocate( sBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = Z(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if( itargdn_nw_loc32 >= 0 ) then + + nebpe = itargdn_nw_loc32 + + + allocate( sBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = Z(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + + endif +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_ne_loc32 >= 0 ) then + nebpe = itargdn_ne_loc32 + + + allocate( sBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = Z(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + endif +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + nebpe = itarg_up + + allocate( rBuf_NE(1:km_16_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + H(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_loc_g32 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsend_loc_g21 & +!*********************************************************************** +! * +! Downsending data from low resolution pes (mygen_up) * +! to the concurent high-resolution pes (mygen_dn) * +! and add the existing and the recevied values * +! ! +! - offset version - ! +! * +!*********************************************************************** +(this,H,V_out,km_4_in,flag) +!----------------------------------------------------------------------- +use mpi +implicit none +class(mg_intstate_type),target::this +!----------------------------------------------------------------------- +integer(i_kind), intent(in):: km_4_in,flag +real(r_kind), dimension(km_4_in,1:this%im,1:this%jm),intent(in):: H +real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(out):: V_out +!----------------------------------------------------------------------- +real(r_kind), allocatable, dimension(:,:,:):: & + sBuf_SW,sBuf_SE,sBuf_NW,sBuf_NE & + ,rBuf_SW,rBuf_SE,rBuf_NW,rBuf_NE + +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_SE +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NW +real(r_kind),dimension(1:km_4_in,1:this%imL,1:this%jmL):: dBuf_NE + +integer(i_kind) sHandle(4),rHandle(4),ISTAT(MPI_STATUS_SIZE) +integer(i_kind) iaerr,ierr,iderr,ndata,i,j,L +integer(i_kind) isend,irecv,nebpe +integer(i_kind):: itarg_up +logical:: lsendup_sw,lsendup_se,lsendup_nw,lsendup_ne +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + + V_out(:,:,:) = 0.0d0 +! +! Define generational flags +! + + itarg_up=Fitargup_loc12(flag) + + ndata =km_4_in*imL*jmL + +! +! --- Send data from SW portion of processors at the higher generation +! to corresponding PE's at lower generation + + + if( itargdn_sw_loc21 >= 0 ) then + nebpe = itargdn_sw_loc21 + + + allocate( sBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SW(:,i,j) = H(:,i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(1), isend) + call MPI_WAIT( sHandle(1), istat, ierr ) + deallocate( sBuf_SW, stat = ierr ) + + endif + +! +! --- Receive SW portion of data at lower generation +! + + + if( lsendup_sw ) then + + nebpe = itarg_up + + + allocate( rBuf_SW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(1), irecv) + call MPI_WAIT( rHandle(1), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=rBuf_SW(:,i,j) + enddo + enddo + + deallocate( rBuf_SW, stat = iderr) + + endif + +! +! --- Send data from SE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_se_loc21 >= 0 ) then + nebpe = itargdn_se_loc21 + + allocate( sBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_SE(:,i,j) = H(:,imL+i,j) + enddo + enddo + + call MPI_ISEND( sBuf_SE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(2), isend) + call MPI_WAIT( sHandle(2), istat, ierr ) + deallocate( sBuf_SE, stat = ierr ) + + + endif +! +! --- Receive SE portion of data at lower generation + + + if( lsendup_se ) then + nebpe = itarg_up + + + allocate( rBuf_SE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_SE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(2), irecv) + call MPI_WAIT( rHandle(2), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=Rbuf_SE(:,i,j) + enddo + enddo + + deallocate( rBuf_SE, stat = iderr) + + end if + +! +! --- Send data from NW portion of processors at the higher generation +! to corresponding PE's at lower generantion + + if( itargdn_nw_loc21 >= 0 ) then + + nebpe = itargdn_nw_loc21 + + + allocate( sBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NW(:,i,j) = H(:,i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NW, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(3), isend) + call MPI_WAIT( sHandle(3), istat, ierr ) + deallocate( sBuf_NW, stat = ierr ) + + + endif +! +! --- Receive NW portion of data at lower generation + + + if( lsendup_nw ) then + + nebpe = itarg_up + + allocate( rBuf_NW(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NW, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(3), irecv) + call MPI_WAIT( rHandle(3), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=Rbuf_NW(:,i,j) + enddo + enddo + + deallocate( rBuf_NW, stat = iderr) + + + end if + + +! --- Send data from NE portion of processors at the higher generation +! to corresponding PE's at lower generation + + if( itargdn_ne_loc21 >= 0 ) then + + nebpe = itargdn_ne_loc21 + + + allocate( sBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + do j=1,jmL + do i=1,imL + sBuf_NE(:,i,j) = H(:,imL+i,jmL+j) + enddo + enddo + + call MPI_ISEND( sBuf_NE, ndata, dtype, nebpe, mype, & + mpi_comm_work, sHandle(4), isend) + call MPI_WAIT( sHandle(4), istat, ierr ) + deallocate( sBuf_NE, stat = ierr ) + + + endif +! +! --- Receive NE portion of data at lower generation +! + + if( lsendup_ne ) then + + nebpe = itarg_up + + allocate( rBuf_NE(1:km_4_in,1:imL,1:jmL), stat = iaerr ) + + call MPI_IRECV( rBuf_NE, ndata, dtype, nebpe, nebpe, & + mpi_comm_work, rHandle(4), irecv) + call MPI_WAIT( rHandle(4), istat, ierr ) + + do j=1,jmL + do i=1,imL + V_out(:,i,j)=rBuf_NE(:,i,j) + enddo + enddo + + deallocate( rBuf_NE, stat = iderr) + + end if + +!----------------------------------------------------------------------- +endsubroutine downsend_loc_g21 + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_bocos diff --git a/src/mgbf/mg_domain.f90 b/src/mgbf/mg_domain.f90 new file mode 100644 index 0000000000..d56d1a5f9f --- /dev/null +++ b/src/mgbf/mg_domain.f90 @@ -0,0 +1,644 @@ +submodule(mg_parameter) mg_domain +!$$$ submodule documentation block +! . . . . +! module: mg_domain +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Definition of a squared integration domain +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_mg_domain - +! init_domain - +! init_topology_2d - +! real_itarg - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use kinds, only: i_kind + +implicit none + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_mg_domain(this) +!*********************************************************************** +! * +! Initialize square domain * +! * +!*********************************************************************** +implicit none +class(mg_parameter_type)::this + +call init_domain(this) +call init_topology_2d(this) + +!----------------------------------------------------------------------- +endsubroutine init_mg_domain + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_domain(this) +!*********************************************************************** +! * +! Definition of constants that control filtering domain * +! * +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this + +integer(i_kind) n,nstrd,i,j +logical:: F=.false., T=.true. + +integer(i_kind):: loc_pe,g +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + + Flwest(1)=nx.eq.1 + Fleast(1)=nx.eq.nxm + Flsouth(1)=my.eq.1 + Flnorth(1)=my.eq.nym + + if(l_hgen) then + + loc_pe=mype_hgen-maxpe_fgen(my_hgen-1) + jy=loc_pe/ixm(my_hgen)+1 + ix=mod(loc_pe,ixm(my_hgen))+1 + + Flwest(2)=ix.eq.1 + Fleast(2)=ix.eq.ixm(my_hgen) + Flsouth(2)=jy.eq.1 + Flnorth(2)=jy.eq.jym(my_hgen) + + else + + jy = -1 + ix = -1 + + Flwest(2)=F + Fleast(2)=F + Flsouth(2)=F + Flnorth(2)=F + + endif + + mype_filt(1)=mype + mype_filt(2)=mype_hgen + +! +! Communication params for analysis grid +! + if(nx==1) then + itarg_wA=-1 + else + itarg_wA=mype-1 + endif + + if(nx==nxm) then + itarg_eA=-1 + else + itarg_eA=mype+1 + endif + + if(my==1) then + itarg_sA=-1 + else + itarg_sA=mype-nxm + endif + + if(my==nym) then + itarg_nA=-1 + else + itarg_nA=mype+nxm + endif + + lwestA=nx.eq.1 + leastA=nx.eq.nxm + lsouthA=my.eq.1 + lnorthA=my.eq.nym + + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! write(100+mype,'(a)')'---------------------------------' +! write(100+mype,'(a)')'From init_domain' +! write(100+mype,'(a,2i5)')'mype=',mype +! write(100+mype,'(a,i5)')'nx=',nx +! write(100+mype,'(a,i5)')'my=',my +! write(100+mype,'(a)')'---------------------------------' +! write(100+mype_filt,'(a)')'---------------------------------' +! write(100+mype_filt,'(a,3i5)')'mype,mype_filt,mygen :',mype,mype_filt,mygen +! write(100+mype_filt,'(a,2i5)')'ix,jy= ',ix,jy +! write(100+mype_filt,'(a,l5)')'lwest = ',lwest +! write(100+mype_filt,'(a,l5)')'least = ',least +! write(100+mype_filt,'(a,l5)')'lsouth= ',lsouth +! write(100+mype_filt,'(a,l5)')'lnorth= ',lnorth +! write(100+mype_filt,'(a,l5)')'lcorner_sw ',lcorner_sw +! write(100+mype_filt,'(a,l5)')'lcorner_se ',lcorner_se +! write(100+mype_filt,'(a,l5)')'lcorner_nw ',lcorner_nw +! write(100+mype_filt,'(a,l5)')'lcorner_ne ',lcorner_ne +! write(100+mype_filt,'(a)')'----------------------------------' +! write(100+mype_filt,'(a)')' ' +!----------------------------------------------------------------------- +! if(mype==0) then +! write(27,'(a,i4)') 'nb=',nb +! write(27,'(a,i4)') 'mb=',mb +! endif +! +! call finishMPI +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!----------------------------------------------------------------------- +endsubroutine init_domain + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_topology_2d(this) +!*********************************************************************** +! * +! Define topology of filter grid * +! - Four generations - * +! * +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +!----------------------------------------------------------------------- +logical:: F=.false., T=.true. + +integer(i_kind) mx2,my2,ix_up,jy_up,ix_dn,jy_dn +integer(i_kind) g,naux,nx_up,my_up +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- +! +! Topology of generations of the squared domain +! +! G1 +! _____ _____ _____ _____ _____ _____ _____ _____ +! | | | | | | | | | +! | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! | | | | | | | | | +! | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | +! |_____|_____|_____|_____|_____|_____|_____|_____| +! +! +! G2 +! ___________ ___________ ___________ ___________ +! | | | | | +! | | | | | +! | 76 | 77 | 78 | 79 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! | | | | | +! | | | | | +! | 72 | 73 | 74 | 75 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! | | | | | +! | | | | | +! | 68 | 69 | 70 | 71 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! | | | | | +! | | | | | +! | 64 | 65 | 66 | 67 | +! | | | | | +! | | | | | +! |___________|___________|___________|___________| +! +! +! G3 +! _______________________ _______________________ +! | | | +! | | | +! | | | +! | | | +! | | | +! | 82 | 83 | +! | | | +! | | | +! | | | +! | | | +! | | | +! |_______________________|_______________________| +! | | | +! | | | +! | | | +! | | | +! | | | +! | 80 | 81 | +! | | | +! | | | +! | | | +! | | | +! | | | +! |_______________________|_______________________| +! +! +! G4 +! _______________________________________________ +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | 84 | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! | | +! |_______________________________________________| +! +!---------------------------------------------------------------------- + + do g = 1,2 +!*** +!*** Send WEST +!*** + if(Flwest(g)) then + Fitarg_w(g) = -1 + else + if(g==1.or.l_hgen) then + Fitarg_w(g) = mype_filt(g)-1 + else + Fitarg_w(g) = -1 + endif + endif +!*** +!*** Send EAST +!*** + if(Fleast(g)) then + Fitarg_e(g) = -1 + else + if(g==1.or.l_hgen) then + Fitarg_e(g) = mype_filt(g)+1 + else + Fitarg_e(g) = -1 + endif + endif + +!*** +!*** Send SOUTH +!*** + + if(Flsouth(g)) then + Fitarg_s(g)=-1 + else + select case(g) + case(1) + naux = nxm + case(2) + if(l_hgen) then + naux = ixm(my_hgen) + endif + endselect + if(g==1.or.l_hgen) then + Fitarg_s(g)=mype_filt(g)-naux + else + Fitarg_s(g)=-1 + endif + endif + +!*** +!*** Send NORTH +!*** + if(Flnorth(g)) then + Fitarg_n(g)=-1 + else + select case(g) + case(1) + naux = nxm + case(2) + if(l_hgen) then + naux = ixm(my_hgen) + endif + endselect + if(g==1.or.l_hgen) then + Fitarg_n(g)=mype_filt(g)+naux + else + Fitarg_n(g)=-1 + endif + endif + +!*** +!*** Send SOUTH-WEST +!*** + + if(Flsouth(g).and.Flwest(g)) then + Fitarg_sw(g)=-1 + else & + if(Flsouth(g)) then + Fitarg_sw(g)=Fitarg_w(g) + else & + if(Flwest(g)) then + Fitarg_sw(g)=Fitarg_s(g) + else + Fitarg_sw(g)=Fitarg_s(g)-1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_sw(g)=-1 + endif + +!*** +!*** Send SOUTH-EAST +!*** + + if(Flsouth(g).and.Fleast(g)) then + Fitarg_se(g)=-1 + else & + if(Flsouth(g)) then + Fitarg_se(g)=Fitarg_e(g) + else & + if(Fleast(g)) then + Fitarg_se(g)=Fitarg_s(g) + else + Fitarg_se(g)=Fitarg_s(g)+1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_se(g)=-1 + endif + +!*** +!*** Send NORTH-WEST +!*** + if(Flnorth(g).and.Flwest(g)) then + Fitarg_nw(g)=-1 + else & + if(Flnorth(g)) then + Fitarg_nw(g)=Fitarg_w(g) + else & + if(Flwest(g)) then + Fitarg_nw(g)=Fitarg_n(g) + else + Fitarg_nw(g)=Fitarg_n(g)-1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_nw(g)=-1 + endif + + +!*** +!*** Send NORTH-EAST +!*** + + if(Flnorth(g).and.Fleast(g)) then + Fitarg_ne(g)=-1 + else & + if(Flnorth(g)) then + Fitarg_ne(g)=Fitarg_e(g) + else & + if(Fleast(g)) then + Fitarg_ne(g)=Fitarg_n(g) + else + Fitarg_ne(g)=Fitarg_n(g)+1 + endif + if(g>1 .and. .not.l_hgen) then + Fitarg_ne(g)=-1 + endif + + + enddo + +!----------------------------------------------------------------------- +! +! Upsending flags +! + + mx2=mod(nx,2) + my2=mod(my,2) + + if(mx2==1.and.my2==1) then + Flsendup_sw(1)=T + else & + if(mx2==0.and.my2==1) then + Flsendup_se(1)=T + else & + if(mx2==1.and.my2==0) then + Flsendup_nw(1)=T + else + Flsendup_ne(1)=T + end if + + nx_up=(nx-1)/2 !+1 + my_up=(my-1)/2 !+1 + + + Fitarg_up(1)=maxpe_fgen(1)+my_up*ixm(2)+nx_up + + + if(l_hgen.and.my_hgen < gm) then + + mx2=mod(ix,2) + my2=mod(jy,2) + + if(mx2==1.and.my2==1) then + Flsendup_sw(2)=T + else & + if(mx2==0.and.my2==1) then + Flsendup_se(2)=T + else & + if(mx2==1.and.my2==0) then + Flsendup_nw(2)=T + else + Flsendup_ne(2)=T + end if + + ix_up=(ix-1)/2 !+1 + jy_up=(jy-1)/2 !+1 + + Fitarg_up(2)=maxpe_fgen(my_hgen)+jy_up*ixm(my_hgen+1)+ix_up + + else + + Flsendup_sw(2)=F + Flsendup_se(2)=F + Flsendup_nw(2)=F + Flsendup_ne(2)=F + + Fitarg_up(2)=-1 + + endif + +! +! Downsending flags +! + + if(my_hgen > 1) then + + ix_dn = 2*ix-1 + jy_dn = 2*jy-1 + + itargdn_sw=maxpe_fgen(my_hgen-2)+(jy_dn-1)*ixm(my_hgen-1)+(ix_dn-1) + itargdn_nw=itargdn_sw+ixm(my_hgen-1) + itargdn_se=itargdn_sw+1 + itargdn_ne=itargdn_nw+1 + + if(Fimax(my_hgen) <= imL .and. Fleast(2)) then + itargdn_se=-1 + itargdn_ne=-1 + endif + if(Fjmax(my_hgen) <= jmL .and. Flnorth(2)) then + itargdn_nw=-1 + itargdn_ne=-1 + end if + + else + + itargdn_sw=-1 + itargdn_se=-1 + itargdn_nw=-1 + itargdn_ne=-1 + + end if +! +! Convert targets in higher generations into real targets +! + call real_itarg(this,Fitarg_w(2)) + call real_itarg(this,Fitarg_e(2)) + call real_itarg(this,Fitarg_s(2)) + call real_itarg(this,Fitarg_n(2)) + + call real_itarg(this,Fitarg_sw(2)) + call real_itarg(this,Fitarg_se(2)) + call real_itarg(this,Fitarg_nw(2)) + call real_itarg(this,Fitarg_ne(2)) + + if(itargdn_sw .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_sw) + if(itargdn_se .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_se) + if(itargdn_nw .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_nw) + if(itargdn_ne .ge. maxpe_fgen(1)) call real_itarg(this,itargdn_ne) + + call real_itarg(this,Fitarg_up(1)) + call real_itarg(this,Fitarg_up(2)) + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! write(200+mype_filt,'(a)')'---------------------------------' +! write(200+mype_filt,'(a)')'From init_topology_2d' +! write(200+mype_filt,'(a,2i5)')'mype=',mype +! write(200+mype_filt,'(a,i5)')'nx=',nx +! write(200+mype_filt,'(a,i5)')'my=',my +! write(200+mype_filt,'(a)')'---------------------------------' +! if(l_hgen ) then +! write(100+mype_filt,*)' ' +! write(100+mype_filt,'(a,2i5)')'I AM (f),(a):',mype_filt,mype +! write(100+mype_filt,'(a,i5)') 'mygen= ',mygen +! +! write(100+mype_filt,'(a,2i5)')'itarg_w=',itarg_w +! write(100+mype_filt,'(a,2i5)')'itarg_e=',itarg_e +! write(100+mype_filt,'(a,2i5)')'itarg_s=',itarg_s +! write(100+mype_filt,'(a,2i5)')'itarg_n=',itarg_n +! +! write(100+mype_filt,'(a,2i5)')'itarg_sw=',itarg_sw +! write(100+mype_filt,'(a,2i5)')'itarg_se=',itarg_se +! write(100+mype_filt,'(a,2i5)')'itarg_nw=',itarg_nw +! write(100+mype_filt,'(a,2i5)')'itarg_ne=',itarg_ne +! write(100+mype_filt,'(a)')' ' +! +! if(lsendup_sw) write(100+mype_filt,'(a,l5)')'lsendup_sw=',lsendup_sw +! if(lsendup_se) write(100+mype_filt,'(a,l5)')'lsendup_se=',lsendup_se +! if(lsendup_nw) write(100+mype_filt,'(a,l5)')'lsendup_nw=',lsendup_nw +! if(lsendup_ne) write(100+mype_filt,'(a,l5)')'lsendup_ne=',lsendup_ne +! +! write(100+mype_filt,'(a,i5)')'itarg_up=',itarg_up +! +! if(lsend_dn) write(100+mype_filt,'(a,l5)')'lsend_dn=',lsend_dn +! +! if(my_hgen > 1) then +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_sw=',mype_hgen,itargdn_sw +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_se=',mype_hgen,itargdn_se +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_nw=',mype_hgen,itargdn_nw +! write(100+mype_hgen,'(a,2i5)')'mype_hgen,itargdn_ne=',mype_hgen,itargdn_ne +! write(100+mype_hgen,'(a,2i5)')' ' +! if(Flsendup_sw(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_sw(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_sw(2),Fitarg_up(2) +! endif +! if(Flsendup_se(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_se(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_se(2),Fitarg_up(2) +! endif +! if(Flsendup_nw(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_nw(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_nw(2),Fitarg_up(2) +! endif +! if(Flsendup_ne(2)) then +! write(mype+600,'(a,i4,l2,i4)')'mype_hgen,Flsendup_ne(2),Fitarg_up(2)= ' & +! ,mype_hgen,Flsendup_ne(2),Fitarg_up(2) +! endif +! call finishMPI +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!----------------------------------------------------------------------- +endsubroutine init_topology_2d +!---------------------------------------------------------------------- +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine real_itarg & +!*********************************************************************** +! * +! Definite real targets for high generations * +! * +!*********************************************************************** +(this,itarg) +!----------------------------------------------------------------------- +implicit none +class(mg_parameter_type),target::this +integer(i_kind), intent(inout):: itarg +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- +if(itarg>-1) then + itarg = itarg-nxy(1) +endif +!----------------------------------------------------------------------- +endsubroutine real_itarg + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_domain diff --git a/src/mgbf/mg_domain_loc.f90 b/src/mgbf/mg_domain_loc.f90 new file mode 100644 index 0000000000..183a5f23d7 --- /dev/null +++ b/src/mgbf/mg_domain_loc.f90 @@ -0,0 +1,796 @@ +submodule(mg_parameter) mg_domain_loc +!$$$ submodule documentation block +! . . . . +! module: mg_domain_loc +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Module that defines control paramters for application +! of MGBF to localization +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_domain_loc - +! sidesend_loc - +! targup_loc - +! targdn21_loc - +! targdn32_loc - +! targdn43_loc - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: i_kind +implicit none + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_domain_loc(this) +!*********************************************************************** +! ! +! Initialize localization with application of MGBF ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type)::this +!---------------------------------------------------------------------- + +call sidesend_loc(this) +call targup_loc(this) +call targdn21_loc(this) +call targdn32_loc(this) +call targdn43_loc(this) + +!---------------------------------------------------------------------- +endsubroutine init_domain_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sidesend_loc(this) +!*********************************************************************** +! ! +! Initialize sidesending pararameters for application MGBF to ! +! localization ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ix_0,jy_0 +integer(i_kind):: ix_c,jy_c +integer(i_kind):: ix_cc,jy_cc +integer(i_kind):: ix_ccc,jy_ccc +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + +! write(10,'(a)') ' Generation 2' +! write(10,'(a)') '----------------------' +! write(10,'(a)') 'mype Flsouth_loc(1) ' + +! write(11,'(a)') ' Generation 2' +! write(11,'(a)') '----------------------' +! write(11,'(a)') 'mype Flnorth_loc(1) ' + +! write(12,'(a)') ' Generation 2' +! write(12,'(a)') '----------------------' +! write(12,'(a)') 'mype Flwest_loc(1) ' + +! write(13,'(a)') ' Generation 2' +! write(13,'(a)') '----------------------' +! write(13,'(a)') 'mype Fleast_loc(1) ' + +! write(14,'(a)') ' Generation 2' +! write(14,'(a)') '----------------------' +! write(14,'(a)') 'mype Fitarg_s_loc(1) ' + +! write(15,'(a)') ' Generation 2' +! write(15,'(a)') '----------------------' +! write(15,'(a)') 'mype Fitarg_n_loc(1) ' + +! write(16,'(a)') ' Generation 2' +! write(16,'(a)') '----------------------' +! write(16,'(a)') 'mype Fitarg_w_loc(1) ' + +! write(17,'(a)') ' Generation 2' +! write(17,'(a)') '----------------------' +! write(17,'(a)') 'mype Fitarg_e_loc(1) ' + +! do mype=0,nxm*nym-1 + +! +! Generation 1 +! + jy_0 = mype/nxm + ix_0 = mype - jy_0*nxm +1 + jy_0 = jy_0 + 1 + + Flsouth_loc(1)=jy_0==1 + Flnorth_loc(1)=jy_0==nym + Flwest_loc(1) =ix_0==1 + Fleast_loc(1) =ix_0==nxm + + if(Flsouth_loc(1)) then + Fitarg_s_loc(1) = -1 + else + Fitarg_s_loc(1) = mype-nxm + endif + + if(Flnorth_loc(1)) then + Fitarg_n_loc(1) = -1 + else + Fitarg_n_loc(1) = mype+nxm + endif + + if(Flwest_loc(1)) then + Fitarg_w_loc(1) = -1 + else + Fitarg_w_loc(1) = mype-1 + endif + + if(Fleast_loc(1)) then + Fitarg_e_loc(1) = -1 + else + Fitarg_e_loc(1) = mype+1 + endif + +! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(1) +! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(1) +! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(1) +! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(1) +! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(1) +! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(1) +! write(16,'(i5,a,i5)') mype, ' ---> ',Fitarg_w_loc(1) +! write(17,'(i5,a,i5)') mype, ' ---> ',Fitarg_e_loc(1) + +! +! Generation 2 +! + + if(ix_0 <= nxm/2 .and. jy_0 <= nym/2) then + ix_c = ix_0 + jy_c = jy_0 + else & + if( (nxm/2 < ix_0 .and. ix_0 <=nxm) .and. jy_0 <= nym/2) then + ix_c = ix_0 - nxm/2 + jy_c = jy_0 + else & + if(ix_0 <= nxm/2 .and. (nym/2 < jy_0 .and. jy_0 <=nym) ) then + ix_c = ix_0 + jy_c = jy_0 - nym/2 + else & + if( (nxm/2 < ix_0 .and. ix_0 <=nxm) .and. (nym/2 < jy_0 .and. jy_0 <=nym) ) then + ix_c = ix_0 - nxm/2 + jy_c = jy_0 - nym/2 + end if + + Flsouth_loc(2)=jy_c==1 + Flnorth_loc(2)=jy_c==nym/2 + Flwest_loc(2) =ix_c==1 + Fleast_loc(2) =ix_c==nxm/2 + + if(Flsouth_loc(2)) then + Fitarg_s_loc(2) = -1 + else + Fitarg_s_loc(2) = mype-nxm + endif + + if(Flnorth_loc(2)) then + Fitarg_n_loc(2) = -1 + else + Fitarg_n_loc(2) = mype+nxm + endif + + if(Flwest_loc(2)) then + Fitarg_w_loc(2) = -1 + else + Fitarg_w_loc(2) = mype-1 + endif + + if(Fleast_loc(2)) then + Fitarg_e_loc(2) = -1 + else + Fitarg_e_loc(2) = mype+1 + endif + +! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(2) +! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(2) +! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(2) +! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(2) +! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(2) +! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(2) + +! +! Generation 3 +! + if(ix_c <= nxm/4 .and. jy_c <= nym/4) then + ix_cc = ix_c + jy_cc = jy_c + else & + if(ix_c > nxm/4 .and. jy_c <= nym/4) then + ix_cc = ix_c-nxm/4 + jy_cc =jy_c + else & + if(ix_c <= nxm/4 .and. jy_c > nym/4) then + ix_cc = ix_c + jy_cc =jy_c-nym/4 + else & + if(ix_c > nxm/4 .and. jy_c > nym/4) then + ix_cc = ix_c-nxm/4 + jy_cc = jy_c-nym/4 + endif + + Flsouth_loc(3)=jy_cc==1 + Flnorth_loc(3)=jy_cc==nym/4 + Flwest_loc(3) =ix_cc==1 + Fleast_loc(3) =ix_cc==nxm/4 + + if(Flsouth_loc(3)) then + Fitarg_s_loc(3) = -1 + else + Fitarg_s_loc(3) = mype-nxm + endif + + if(Flnorth_loc(3)) then + Fitarg_n_loc(3) = -1 + else + Fitarg_n_loc(3) = mype+nxm + endif + + if(Flwest_loc(3)) then + Fitarg_w_loc(3) = -1 + else + Fitarg_w_loc(3) = mype-1 + endif + + if(Fleast_loc(3)) then + Fitarg_e_loc(3) = -1 + else + Fitarg_e_loc(3) = mype+1 + endif + +! write(10,'(i5,a,l5)') mype, ' ---> ',Flsouth_loc(3) +! write(11,'(i5,a,l5)') mype, ' ---> ',Flnorth_loc(3) +! write(12,'(i5,a,l5)') mype, ' ---> ',Flwest_loc(3) +! write(13,'(i5,a,l5)') mype, ' ---> ',Fleast_loc(3) +! write(14,'(i5,a,i5)') mype, ' ---> ',Fitarg_s_loc(3) +! write(15,'(i5,a,i5)') mype, ' ---> ',Fitarg_n_loc(3) + +! +! Generation 4 +! + if(ix_cc <= nxm/8 .and. jy_cc <= nym/8) then + ix_ccc = ix_cc; jy_ccc = jy_cc + else & + if(ix_cc > nxm/8 .and. jy_cc <= nym/8) then + ix_ccc = ix_cc-nxm/8; jy_ccc =jy_cc + else & + if(ix_cc <= nxm/8 .and. jy_cc > nym/8) then + ix_ccc = ix_cc; jy_ccc =jy_cc-nym/8 + else & + if(ix_cc > nxm/8 .and. jy_cc > nym/8) then + ix_ccc = ix_cc-nxm/8; jy_ccc =jy_cc-nym/8 + endif + + Flsouth_loc(4)=jy_ccc==1 + Flnorth_loc(4)=jy_ccc==nym/8 + Flwest_loc(4) =ix_ccc==1 + Fleast_loc(4) =ix_ccc==nxm/8 + + if(Flsouth_loc(4)) then + Fitarg_s_loc(4) = -1 + else + Fitarg_s_loc(4) = mype-nxm + endif + + if(Flnorth_loc(4)) then + Fitarg_n_loc(4) = -1 + else + Fitarg_n_loc(4) = mype+nxm + endif + + if(Flwest_loc(4)) then + Fitarg_w_loc(4) = -1 + else + Fitarg_w_loc(4) = mype-1 + endif + + if(Fleast_loc(4)) then + Fitarg_e_loc(4) = -1 + else + Fitarg_e_loc(4) = mype+1 + endif + +! enddo + +!---------------------------------------------------------------------- +endsubroutine sidesend_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine targup_loc(this) +!*********************************************************************** +! ! +! Initialize upsending pararameters for application MGBF to ! +! localization ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ix_0,jy_0 +integer(i_kind):: ix_c,jy_c,mype_c +integer(i_kind):: ix_prox,jy_prox,targup +integer(i_kind):: n,is,js, mj2, il,jl +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!-------------------------------------------------------------------- + +!do mype=0,nxm*nym-1 + + jy_0 = mype/nxm+1 + ix_0 = mype-(jy_0-1)*nxm+1 + + mj2=mod(jy_0,2) + mype_c=(nxm/2)*(jy_0-2+mj2)/2+(ix_0-1)/2 + + jy_c = mype_c/(nxm/2)+1 + ix_c = mype_c-(jy_c-1)*(nxm/2)+1 + + lsendup_sw_loc=(mod(ix_0,2)==1).and.(mod(jy_0,2)==1) + lsendup_se_loc=(mod(ix_0,2)==0).and.(mod(jy_0,2)==1) + lsendup_nw_loc=(mod(ix_0,2)==1).and.(mod(jy_0,2)==0) + lsendup_ne_loc=(mod(ix_0,2)==0).and.(mod(jy_0,2)==0) + +! +! g1 --> g2 +! + + do n=1,4 + js=(n-1)/2 + is= n-1 -js*2 + ix_prox=ix_c+is*nxm/2 + jy_prox=jy_c+js*nym/2 + + Fitargup_loc12(n)=nxm*(jy_prox-1)+ix_prox-1 + enddo + +! write(12,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc12(1),Fitargup_loc12(2),Fitargup_loc12(3),Fitargup_loc12(4) + +! +! g2 --> g3 +! + il = (ix_0-1)/(nxm/2) + jl = (jy_0-1)/(nym/2) + + do n=1,4 + js=(n-1)/2 + is= n-1-js*2 + ix_prox=ix_c +is*nxm/4 + il*nxm/4 + jy_prox=jy_c +js*nym/4 + jl*nym/4 + + Fitargup_loc23(n)=nxm*(jy_prox-1)+ix_prox-1 + enddo + +! write(23,'(i5,a,4i5)') mype,' ---> ', Fitargup_loc23(1),Fitargup_loc23(2),Fitargup_loc23(3),Fitargup_loc23(4) + +! +! g3 --> g4 +! + il = (ix_0-1)/(nxm/4) + jl = (jy_0-1)/(nym/4) + + do n=1,4 + js=(n-1)/2 + is= n-1-js*2 + ix_prox=ix_c +is*nxm/8 + il*nxm/8 + jy_prox=jy_c +js*nym/8 + jl*nym/8 + + Fitargup_loc34(n)=nxm*(jy_prox-1)+ix_prox-1 + enddo + +! write(34,'(i5,a,4i5)') mype,' ---> ', +!Fitargup_loc34(1),Fitargup_loc34(2),Fitargup_loc34(3),Fitargup_loc34(4) + +!enddo + +!---------------------------------------------------------------------- +endsubroutine targup_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine targdn21_loc(this) +!*********************************************************************** +! ! +! Initialize downsending pararameters for application MGBF to ! +! localization from g2 go g1 ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer:: ix_t,jy_t +integer:: ix_l,jy_l +integer:: ix_sw,jy_sw +integer:: ix_se,jy_se +integer:: ix_nw,jy_nw +integer:: ix_ne,jy_ne +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!------------------------------------------------------------------------ + +! write(11,'(a)') 'mype itargdn_xx_loc21 nsq21 ' +! write(11,'(a)') '---------------------------------' + +! do mype=0,nxm*nym-1 + + jy_t = mype/nxm+1 + ix_t = mype-(jy_t-1)*nxm+1 + +! +! Square 1 +! + if(ix_t <= nxm/2 .and. jy_t <= nym/2) then + ix_l = ix_t + jy_l = jy_t + nsq21 = 1 + else & +! +! Square 2 +! + if( (nxm/2 < ix_t .and. ix_t <= nxm) .and. jy_t <= nym/2) then + ix_l = ix_t-nxm/2 + jy_l = jy_t + nsq21 = 2 + else & +! +! Square 3 +! + if( ix_t <= nxm/2 .and. (nym/2 < jy_t .and. jy_t <= nym)) then + ix_l = ix_t + jy_l = jy_t-nym/2 + nsq21 = 3 + else & +! +! Square 4 +! + if( (nxm/2 < ix_t .and. ix_t <= nxm) .and. (nym/2 < jy_t .and. jy_t <= nym)) then + ix_l = ix_t-nxm/2 + jy_l = jy_t-nym/2 + nsq21 = 4 + endif + + ix_sw = 2*ix_l-1 + jy_sw = 2*jy_l-1 + itargdn_sw_loc21 = nxm*(jy_sw-1)+ix_sw-1 + + ix_se = ix_sw+1 + jy_se = jy_sw + itargdn_se_loc21 = nxm*(jy_se-1)+ix_se-1 + + ix_nw = ix_sw + jy_nw = jy_sw+1 + itargdn_nw_loc21 = nxm*(jy_nw-1)+ix_nw-1 + + ix_ne = ix_nw+1 + jy_ne = jy_nw + itargdn_ne_loc21 = nxm*(jy_ne-1)+ix_ne-1 + +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_sw_loc21 ',itargdn_sw_loc21,nsq +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_se_loc21 ',itargdn_se_loc21,nsq +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_nw_loc21 ',itargdn_nw_loc21,nsq +! write(11,'(i6,a,2i4)') mype,' <-- itargdn_ne_loc21 ',itargdn_ne_loc21,nsq + +! end do +!----------------------------------------------------------- +endsubroutine targdn21_loc + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine targdn32_loc(this) +!*********************************************************************** +! ! +! Initialize downsending pararameters for application MGBF to ! +! localization from g3 go g2 ! +! ! +!*********************************************************************** +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ix_t,jy_t +integer(i_kind):: ix_l,jy_l +integer(i_kind):: ix_sw,jy_sw +integer(i_kind):: ix_se,jy_se +integer(i_kind):: ix_nw,jy_nw +integer(i_kind):: ix_ne,jy_ne +integer(i_kind):: facx,facy +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------- + +! write(32,'(a)') 'mype itargdn_xx_loc32 nsq32 ' +! write(32,'(a)') '---------------------------------' + +! do mype=0,nxm*nym-1 + + jy_t = mype/nxm+1 + ix_t = mype-(jy_t-1)*nxm+1 + +! +! Square 1 +! + if(ix_t <= nxm/4 .and. jy_t <= nym/4) then + ix_l = ix_t + jy_l = jy_t + nsq32 = 1 + facx = 0 + facy = 0 + else & +! +! Square 2 +! + if( (nxm/4 < ix_t .and.ix_t<=nxm/2 ) .and. jy_t <= nym/4) then + ix_l = ix_t-nxm/4 + jy_l = jy_t + nsq32 = 2 + facx = 0 + facy = 0 + else & +! +! Square 3 +! + if( ix_t <= nxm/4 .and. (nym/4 < jy_t .and. jy_t <= nym/2)) then + ix_l = ix_t + jy_l = jy_t-nym/4 + nsq32 = 3 + facx = 0 + facy = 0 + else & +! +! Square 4 +! + if( (nxm/4 < ix_t .and. ix_t <= nxm/2) .and. (nym/4 < jy_t .and. jy_t <= nym/2)) then + ix_l = ix_t-nxm/4 + jy_l = jy_t-nym/4 + nsq32 = 4 + facx = 0 + facy = 0 + else & +! +! Square 5 +! + if( (nxm/2 1) call this%init_mg_MPI + +!*** +!*** Initialize integration domain +!*** +call this%init_mg_domain +if(this%l_loc) then + call this%init_domain_loc +endif + +!--------------------------------------------------------------------------- +! +! All others are function of km2,km3,km,nm,mm,im,jm +! and needs to be called separately for each application +! +!--------------------------------------------------------------------------- +!*** +!*** Define km and WORKA array based on input from mg_parameters and +!*** depending on specific application +!*** + +!*** +!*** Allocate variables, define weights, prepare mapping +!*** between analysis and filter grid +!*** + +call this%allocate_mg_intstate + +call this%def_offset_coef + +call this%def_mg_weights + +if(this%mgbf_line) then + call this%init_mg_line +endif + +call this%lsqr_mg_coef + +call this%lwq_vertical_coef(this%lm_a,this%lm,this%cvf1,this%cvf2,this%cvf3,this%cvf4,this%lref) + +!*** +!*** Just for testing of standalone version. In GSI WORKA will be given +!*** through a separate subroutine +!*** + +!call input_3d(WORKA( 1: lm,:,:),1,1, 1,mm,nm, lm,mm0,4,3) +!call input_3d(WORKA( lm+1:2*lm,:,:),1,1, lm+1,mm,nm,2*lm,mm0,6,5) +!call input_3d(WORKA(2*lm+1:3*lm,:,:),1,1,2*lm+1,mm,nm,3*lm,mm0,2,1) +!call input_3d(WORKA(3*lm+1:4*lm,:,:),1,1,3*lm+1,mm,nm,4*lm,mm0,3,2) +!call input_3d(WORKA(4*lm+1:5*lm,:,:),1,1,4*lm+1,mm,nm,5*lm,mm0,7,3) +!call input_3d(WORKA(5*lm+1:6*lm,:,:),1,1,5*lm+1,mm,nm,6*lm,mm0,4,5) + +!call input_3d(WORKA(6*lm+1:6*lm+1,:,:),1,1,6*lm+1,mm,nm,6*lm+1,mm0,2,1) +!call input_3d(WORKA(6*lm+2:6*lm+2,:,:),1,1,6*lm+2,mm,nm,6*lm+2,mm0,4,1) +!call input_3d(WORKA(6*lm+3:6*lm+3,:,:),1,1,6*lm+3,mm,nm,6*lm+3,mm0,5,1) +!call input_3d(WORKA(6*lm+4:6*lm+4,:,:),1,1,6*lm+4,mm,nm,6*lm+4,mm0,7,1) + +!----------------------------------------------------------------------- +endsubroutine mg_initialize + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine mg_finalize(this) +!**********************************************************************! +! ! +! Finalize multigrid Beta Function ! +! M. Rancic (2020) ! +!*********************************************************************** +implicit none +class (mg_intstate_type)::this + +real(r_kind), allocatable, dimension(:,:):: PA, VA +integer(i_kind):: n,m,L +integer:: nm,mm,lm +!----------------------------------------------------------------------- + +if(this%ldelta) then + ! + ! Horizontal cross-section + ! + nm=this%nm + mm=this%mm + lm=this%lm +endif + +if(this%nxm*this%nym>1) call this%barrierMPI + +call this%deallocate_mg_intstate + +!----------------------------------------------------------------------- +endsubroutine mg_finalize +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_entrymod diff --git a/src/mgbf/mg_filtering.f90 b/src/mgbf/mg_filtering.f90 new file mode 100644 index 0000000000..714a4b6bf4 --- /dev/null +++ b/src/mgbf/mg_filtering.f90 @@ -0,0 +1,1629 @@ +submodule(mg_intstate) mg_filtering +!$$$ submodule documentation block +! . . . . +! module: mg_filtering +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Contains all multigrid filtering prodecures +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! filtering_procedure - +! filtering_rad3 - +! filtering_lin3 - +! filtering_rad2_bkg - +! filtering_lin2_bkg - +! filtering_fast_bkg - +! filtering_rad2_ens - +! filtering_lin2_ens - +! filtering_fast_ens - +! filtering_rad_highest - +! sup_vrbeta1 - +! sup_vrbeta1T - +! sup_vrbeta3 - +! sup_vrbeta3T - +! sup_vrbeta1_ens - +! sup_vrbeta1T_ens - +! sup_vrbeta1_bkg - +! sup_vrbeta1T_bkg - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mg_timers +use kinds, only: r_kind,i_kind +use jp_pbfil3, only: dibetat,dibeta +use mpi + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) +!*********************************************************************** +! ! +! Driver for Multigrid filtering procedures with Helmholtz operator ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt +integer(i_kind),intent(in):: mg_filt_flag +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +if(this%nxm*this%nym>1) then + select case(mg_filt) + case(1) + call this%filtering_rad3 + case(2) + call this%filtering_lin3 + case(3) + call this%filtering_rad2_bkg + case(4) + call this%filtering_lin2_bkg + case(5) + call this%filtering_fast_bkg + case(6) + call this%filtering_rad2_ens(mg_filt_flag) + case(7) + call this%filtering_lin2_ens(mg_filt_flag) + case(8) + call this%filtering_fast_ens(mg_filt_flag) + end select +else + call this%filtering_rad_highest +endif +!----------------------------------------------------------------------- +endsubroutine filtering_procedure + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad3(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Multiple of 2D and 3D variables ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 3d radial filter ! +! ! +!*********************************************************************** +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target::this +real(r_kind), allocatable, dimension(:,:,:):: VM2D +real(r_kind), allocatable, dimension(:,:,:):: HM2D +real(r_kind), allocatable, dimension(:,:,:,:):: VM3D +real(r_kind), allocatable, dimension(:,:,:,:):: HM3D +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(VM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; HM2D=0. + +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%rbetaT(km2,hx,1,im,hy,1,jm,pasp2,ss2,VM2D) + call this%sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%rbetaT(km2,hx,1,im,hy,1,jm,pasp2,ss2,HM2D) + call this%sup_vrbeta3T(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfiltT_tim) + + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + + call btim(hfilt_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + call this%rbeta(km2,hx,1,im,hy,1,jm,pasp2,ss2,VM2D(:,:,:)) + call this%sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,VM3D) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + call this%rbeta(km2,hx,1,im,hy,1,jm,pasp2,ss2,HM2D(:,:,:)) + call this%sup_vrbeta3(km3,hx,hy,hz,im,jm,lm,pasp3,ss3,HM3D) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add +!*** Then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) +!----------------------------------------------------------------------- +endsubroutine filtering_rad3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_lin3(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Multiple of 2D line filter ! +! - 1 upsending and downsending ! +! - Applicaton of Helmholtz differential operator ! +! - 3d line filter ! +! ! +!*********************************************************************** +!TEST +use, intrinsic :: ieee_arithmetic +!TEST +use jp_pkind2, only: fpi +implicit none +class (mg_intstate_type),target::this +integer(i_kind) k,i,j,L +integer(i_kind) icol,iout,jout,lout +logical:: ff +real(r_kind), allocatable, dimension(:,:,:):: VM2D +real(r_kind), allocatable, dimension(:,:,:):: HM2D +real(r_kind), allocatable, dimension(:,:,:,:):: VM3D +real(r_kind), allocatable, dimension(:,:,:,:):: HM3D +real(r_kind), allocatable, dimension(:,:,:,:):: W +real(r_kind), allocatable, dimension(:,:,:,:):: H +integer(fpi), allocatable, dimension(:,:,:):: JCOL +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +allocate(VM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; VM3D=0. +allocate(VM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; VM2D=0. +allocate(HM3D(km3,1-hx:im+hx,1-hy:jm+hy,lm)) ; HM3D=0. +allocate(HM2D(km2,1-hx:im+hx,1-hy:jm+hy )) ; HM2D=0. +allocate(W(km3,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz)) ; W=0. +allocate(H(km3,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz)) ; H=0. +allocate(JCOL(1:im,1:jm,1:Lm)) ; JCOL=0 + +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + +! +! From single stack to composite variables +! + call btim(hfiltT_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + endif + call etim(hfiltT_tim) +! +! Apply adjoint filter to 2D variables first +! + do icol=3,1,-1 + call btim(hfiltT_tim) + call dibetat(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_2d(VM2D,km2,im,jm,hx,hy) + call etim(bocoT_tim) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + call dibetat(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +! +! Create and apply adjoint filter to extended 3D variables +! + W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) + do icol=7,1,-1 + call btim(hfiltT_tim) + do L=1,hz + W(:,:,:,1-L )=W(:,:,:,1+L ) + W(:,:,:,LM+L)=W(:,:,:,LM-L) + enddo + call dibetat(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_3d(W,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax) + call etim(bocoT_tim) + enddo + + if(l_hgen) then + H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) + endif + do icol=7,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + do L=1,hz + H(:,:,:,1-L )=H(:,:,:,1+L ) + H(:,:,:,LM+L)=H(:,:,:,LM-L) + end do + call dibetat(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_3d(H,km3,im,jm,Lm,hx,hy,hz,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +! +! Go back from extended 3D variables and combine them with 2D variables in one stacked variable +! + call btim(hfiltT_tim) + VM3D(:,:,:,1:lm)=W(:,:,:,1:lm) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfiltT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + +! +! From single stacked to composite variables +! + call btim(hfilt_tim) + call this%stack_to_composite(VALL,VM2D,VM3D) + if(l_hgen) then + call this%stack_to_composite(HALL,HM2D,HM3D) + endif + call etim(hfilt_tim) +! +! Apply filter to 2D variables first +! + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(VM2D,km2,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), VM2D, ff, iout,jout) + call etim(hfilt_tim) + enddo + + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(HM2D,km2,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km2,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol), HM2D, ff, iout,jout) + call etim(hfilt_tim) + endif + enddo +! +! Create and apply filter to extended 3D variables +! + W(:,:,:,1:lm)=VM3D(:,:,:,1:lm) + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1-L )=W(:,i,j,1+L ) + W(:,i,j,LM+L)=W(:,i,j,LM-L) + enddo + enddo + enddo + + do icol=1,7 + call btim(boco_tim) + call this%boco_3d(W,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, W, ff, iout,jout,lout) + call etim(hfilt_tim) + enddo + + if(l_hgen) then + H(:,:,:,1:lm)=HM3D(:,:,:,1:lm) + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + H(:,i,j,1-L )=H(:,i,j,1+L ) + H(:,i,j,LM+L)=H(:,i,j,LM-L) + enddo + enddo + enddo + endif + do icol=1,7 + call btim(boco_tim) + call this%boco_3d(H,km3,im,jm,lm,hx,hy,hz,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km3,1-hx,1,im,im+hx, 1-hy,1,jm,jm+hy, 1-hz,1,lm,lm+hz,icol, nfil & + ,qcols,dixs3,diys3,dizs3,JCOL,vpasp3, H, ff, iout,jout,lout) + call etim(hfilt_tim) + endif + enddo +! +! Go back from extended 3D variables and combine them with 2D variables in one stacked variable +! + call btim(hfilt_tim) + VM3D(:,:,:,1:lm)=W(:,:,:,1:lm) + call this%composite_to_stack(VM2D,VM3D,VALL) + if(l_hgen) then + HM3D(:,:,:,1:lm)=H(:,:,:,1:lm) + call this%composite_to_stack(HM2D,HM3D,HALL) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) + +deallocate(VM3D) +deallocate(VM2D) +deallocate(HM3D) +deallocate(HM2D) +deallocate(W) +deallocate(H) +deallocate(JCOL) +!----------------------------------------------------------------------- +endsubroutine filtering_lin3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad2_bkg(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 2d radial filter ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + call this%rbetaT(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + if(l_hgen) then + call this%rbetaT(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfiltT_tim) + + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + + call btim(hfilt_tim) + call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + if(l_hgen) then + call this%rbeta(km,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +!----------------------------------------------------------------------- +endsubroutine filtering_rad2_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_lin2_bkg(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 2d line filter ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +logical:: ff +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + do icol=3,1,-1 + call btim(hfiltT_tim) + call dibetat(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km,im,jm,hx,hy) + call etim(bocoT_tim) + enddo + + do icol=3,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + call dibetat(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(VALL,km,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfilt_tim) + enddo + + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfilt_tim) + endif + enddo +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +!----------------------------------------------------------------------- +endsubroutine filtering_lin2_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_fast_bkg(this) +!*********************************************************************** +! ! +! Fast multigrid filtering procedure: ! +! ! +! - Apply adjoint of vertical filter before and directec vertical ! +! filter after horizontal ! +! - 1d+1d horizontal filter ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_all(VALL,HALL,lquart) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTy(VALL,km,im,jm,hx,hy) + call etim(bocoT_tim) + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTx(VALL,km,im,jm,hx,hy) + call etim(bocoT_tim) + if(l_hgen) then + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + if(l_hgen) then + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTx(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_all(VALL,HALL,lhelm) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + call this%bocox(VALL,km,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfilt_tim) + call btim(boco_tim) + call this%bocoy(VALL,km,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfilt_tim) + call btim(boco_tim) + call this%bocox(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfilt_tim) + endif + call btim(boco_tim) + call this%bocoy(HALL,km,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfilt_tim) + endif +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_all(HALL,VALL,lquart) + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_bkg(km,km3,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +!----------------------------------------------------------------------- +endsubroutine filtering_fast_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad2_ens(this,mg_filt_flag) +!*********************************************************************** +! ! +! Multigrid filtering procedure for ensemble: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 2d radial filter ! +! - Version for localization of ensemble ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt_flag +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +if(mg_filt_flag==1) then + call btim(upsend_tim) + call this%upsending_ens_nearest(VALL,HALL,km_all) + call etim(upsend_tim) +else +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + if(lquart) then + call this%upsending2_ens(VALL,HALL,km_all) + else + call this%upsending_ens(VALL,HALL,km_all) + endif + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + if(l_filt_g1) then + call this%rbetaT(km_all,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + endif + if(l_hgen) then + call this%rbetaT(km_all,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfiltT_tim) + + call btim(bocoT_tim) + if(l_filt_g1) then + call this%bocoT_2d(VALL,km_all,im,jm,hx,hy) + endif + call this%bocoT_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +endif +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) + +if(mg_filt_flag==-1) then + call btim(dnsend_tim) + call this%downsending_ens_nearest(HALL,VALL,km_all) + call etim(dnsend_tim) +else +!*** +!*** Apply Beta filter at all generations +!*** + call btim(boco_tim) + if(l_filt_g1) then + call this%boco_2d(VALL,km_all,im,jm,hx,hy) + endif + call this%boco_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + + call btim(hfilt_tim) + if(l_filt_g1) then + call this%rbeta(km_all,hx,1,im,hy,1,jm,pasp2,ss2,VALL(:,:,:)) + endif + if(l_hgen) then + call this%rbeta(km_all,hx,1,im,hy,1,jm,pasp2,ss2,HALL(:,:,:)) + endif + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + if(lquart) then + call this%downsending2_ens(HALL,VALL,km_all) + else + call this%downsending_ens(HALL,VALL,km_all) + endif + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +endif +!----------------------------------------------------------------------- +endsubroutine filtering_rad2_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_lin2_ens(this,mg_filt_flag) +!*********************************************************************** +! ! +! Multigrid filtering procedure for ensemble: ! +! ! +! - Vertical filter before and after horizontal ! +! - Line filters in horizontal ! +! - Version for localization of ensemble ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt_flag +integer(i_kind) L,i,j +integer(i_kind) icol,iout,jout +logical:: ff +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +if(mg_filt_flag==1) then + call btim(upsend_tim) + call this%upsending_ens_nearest(VALL,HALL,km_all) + call etim(upsend_tim) +else +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + if(lquart) then + call this%upsending2_ens(VALL,HALL,km_all) + else + call this%upsending_ens(VALL,HALL,km_all) + endif + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + if(l_filt_g1) then + do icol=3,1,-1 + call btim(hfiltT_tim) + call dibetat(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoT_2d(VALL,km_all,im,jm,hx,hy) + call etim(bocoT_tim) + enddo + endif + + do icol=3,1,-1 + if(l_hgen) then + call btim(hfiltT_tim) + call dibetat(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoT_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + enddo +endif +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) + +if(mg_filt_flag==-1) then + call btim(dnsend_tim) + call this%downsending_ens_nearest(HALL,VALL,km_all) + call etim(dnsend_tim) +else +!*** +!*** Apply Beta filter at all generations +!*** + if(l_filt_g1) then + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(VALL,km_all,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + call dibeta(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),VALL,ff,iout,jout) + call etim(hfilt_tim) + enddo + endif + + do icol=1,3 + call btim(boco_tim) + call this%boco_2d(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + call dibeta(km_all,1-hx,1,im,im+hx,1-hy,1,jm,jm+hy,nfil, & + dixs(:,:,icol),diys(:,:,icol),hss2(:,:,icol),HALL,ff,iout,jout) + call etim(hfilt_tim) + endif + enddo +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + if(lquart) then + call this%downsending2_ens(HALL,VALL,km_all) + else + call this%downsending_ens(HALL,VALL,km_all) + endif + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +endif +!----------------------------------------------------------------------- +endsubroutine filtering_lin2_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_fast_ens(this,mg_filt_flag) +!*********************************************************************** +! ! +! Fast multigrid filtering procedure for ensemble: ! +! ! +! - Apply vertical filter before and after horizontal ! +! - 1d+1d horizontal filter + 1d vertical filter ! +! - Version for localizaiton of ensemble ! +! ! +!*********************************************************************** +implicit none +class (mg_intstate_type),target::this +integer(i_kind),intent(in):: mg_filt_flag +integer(i_kind) L,i,j +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- +if(mg_filt_flag==1) then + call btim(upsend_tim) + call this%upsending_ens_nearest(VALL,HALL,km_all) + call etim(upsend_tim) +else +!*** +!*** Adjoint of beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfiltT_tim) + call this%sup_vrbeta1T_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfiltT_tim) + endif +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + if(lquart) then + call this%upsending2_ens(VALL,HALL,km_all) + else + call this%upsending_ens(VALL,HALL,km_all) + endif + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + if(l_filt_g1) then + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km_all,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTy(VALL,km_all,im,jm,hx,hy) + call etim(bocoT_tim) + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km_all,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfiltT_tim) + call btim(bocoT_tim) + call this%bocoTx(VALL,km_all,im,jm,hx,hy) + call etim(bocoT_tim) + endif + if(l_hgen) then + call btim(hfiltT_tim) + do i=im,1,-1 + call this%rbetaT(km_all,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTy(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) + if(l_hgen) then + call btim(hfiltT_tim) + do j=jm,1,-1 + call this%rbetaT(km_all,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfiltT_tim) + endif + call btim(bocoT_tim) + call this%bocoTx(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(bocoT_tim) +endif +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_ens(VALL,HALL,km_all) + call etim(weight_tim) + +if(mg_filt_flag==-1) then + call btim(dnsend_tim) + call this%downsending_ens_nearest(HALL,VALL,km_all) + call etim(dnsend_tim) +else +!*** +!*** Apply Beta filter at all generations +!*** + if(l_filt_g1) then + call btim(boco_tim) + call this%bocox(VALL,km_all,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km_all,hx,1,im,paspx,ssx,VALL(:,:,j)) + enddo + call etim(hfilt_tim) + call btim(boco_tim) + call this%bocoy(VALL,km_all,im,jm,hx,hy) + call etim(boco_tim) + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km_all,hy,1,jm,paspy,ssy,VALL(:,i,:)) + enddo + call etim(hfilt_tim) + endif + call btim(boco_tim) + call this%bocox(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do j=1,jm + call this%rbeta(km_all,hx,1,im,paspx,ssx,HALL(:,:,j)) + enddo + call etim(hfilt_tim) + endif + call btim(boco_tim) + call this%bocoy(HALL,km_all,im,jm,hx,hy,Fimax,Fjmax,2,gm) + call etim(boco_tim) + if(l_hgen) then + call btim(hfilt_tim) + do i=1,im + call this%rbeta(km_all,hy,1,jm,paspy,ssy,HALL(:,i,:)) + enddo + call etim(hfilt_tim) + endif +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + if(lquart) then + call this%downsending2_ens(HALL,VALL,km_all) + else + call this%downsending_ens(HALL,VALL,km_all) + endif + call etim(dnsend_tim) +!*** +!*** Apply beta filter in vertical direction +!*** + if(l_vertical_filter) then + call btim(vfilt_tim) + call this%sup_vrbeta1_ens(km3_all,hx,hy,hz,im,jm,lm,pasp1,ss1,VALL) + call etim(vfilt_tim) + endif +endif +!----------------------------------------------------------------------- +endsubroutine filtering_fast_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filtering_rad_highest(this) +!*********************************************************************** +! ! +! Multigrid filtering procedure: ! +! ! +! - 2d radial filter only for the highest generation ! +! - Without horizontal parallelization ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target:: this +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!----------------------------------------------------------------------- + +!*** +!*** Adjoint interpolate and upsend +!*** + call btim(upsend_tim) + call this%upsending_highest(VALL,HALL) + call etim(upsend_tim) +!*** +!*** Apply adjoint of Beta filter at all generations +!*** + call btim(hfiltT_tim) + call this%rbetaT(km,hx,1,imH,hy,1,jmH,& + &pasp2(:,:,1:imH,1:jmH),ss2(1:imH,1:jmH),HALL(:,1-hx:imH+hx,1-hy:jmH+hy)) + call etim(hfiltT_tim) +!*** +!*** Apply (a-b\nabla^2) +!*** + call btim(weight_tim) + call this%weighting_highest(HALL(:,1-hx:imH+hx,1-hy:jmH+hy)) + call etim(weight_tim) +!*** +!*** Apply Beta filter at all generations +!*** + call btim(hfilt_tim) + call this%rbeta(km,hx,1,imH,hy,1,jmH,& + &pasp2(:,:,1:imH,1:jmH),ss2(1:imH,1:jmH),HALL(:,1-hx:imH+hx,1-hy:jmH+hy)) + call etim(hfilt_tim) +!*** +!*** Downsend, interpolate and add, then zero high generations +!*** + call btim(dnsend_tim) + call this%downsending_highest(HALL,VALL) + call etim(dnsend_tim) + +!----------------------------------------------------------------------- +endsubroutine filtering_rad_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1 & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hz:lm+hz):: W +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do L=1,Lm + W(:,L)=V(:,i,j,L) + end do + do L=1,hz + W(:,1-L)=W(:,1+L) + W(:,LM+L)=W(:,LM-L) + end do + call this%rbeta(kmax,hz,1,lm, pasp,ss,W) + do l=1,Lm + V(:,i,j,L)=W(:,L) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1T & +!********************************************************************** +! * +! Adjoint of sup_vrbeta1 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hz:lm+hz):: W +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do L=1,Lm + W(:,L)=V(:,i,j,L) + end do + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + call this%rbetaT(kmax,hz,1,lm, pasp,ss,W) +! +! Apply adjoint at the edges of domain +! + do L=1,hz + W(:,1+L)=W(:,1+L)+W(:,1-L) + W(:,LM-L)=W(:,LM-L)+W(:,LM+L) + enddo + do l=1,Lm + V(:,i,j,L)=W(:,L) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1T + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta3 & +!********************************************************************** +! * +! conversion of vrbeta3 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz):: W +integer(i_kind):: i,j,L +!---------------------------------------------------------------------- + + do L=1,Lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,L)=V(:,i,j,L) + end do + end do + end do + + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1-L )=W(:,i,j,1+L ) + W(:,i,j,LM+L)=W(:,i,j,LM-L) + end do + end do + end do + + + call this%rbeta(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W) + + + do l=1,Lm + do j=1,jm + do i=1,im + V(:,i,j,L)=W(:,i,j,L) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta3T & +!********************************************************************** +! * +! Adjoint of sup_vrbeta3 * +! * +!********************************************************************** +(this,kmax,hx,hy,hz,im,jm,lm,pasp,ss,V) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V +real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp +real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss +real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1-hz:lm+hz):: W +integer(i_kind):: i,j,l +!---------------------------------------------------------------------- + + do L=1,Lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,L)=V(:,i,j,L) + end do + end do + end do + + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1-L )=W(:,i,j, 1+L) + W(:,i,j,LM+L)=W(:,i,j,LM-L) + end do + end do + end do + + + call this%rbetaT(kmax,hx,1,im, hy,1,jm, hz,1,lm, pasp,ss,W) + +! +! Apply adjoint at the edges of domain +! + do L=1,hz + do j=1-hy,jm+hy + do i=1-hx,im+hx + W(:,i,j,1+L )=W(:,i,j, 1+L)+W(:,i,j, 1-L) + W(:,i,j,LM-L)=W(:,i,j,LM-L)+W(:,i,j,LM+L) + end do + end do + end do + + do l=1,lm + do j=1,jm + do i=1,im + V(:,i,j,l)=W(:,i,j,l) + end do + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta3T + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1_ens & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km_en,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do k=1,km_en + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbeta(km_en,hz,1,lm, pasp,ss,W) + + do k=1,km_en + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)= W(k,L) + end do + enddo + enddo + enddo + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1T_ens & +!********************************************************************** +! * +! Adjoint of sup_vrbeta1_ens * +! * +!********************************************************************** +(this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km_en,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + + do k=1,km_en + k_ind = (k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbetaT(km_en,hz,1,lm, pasp,ss,W) +! +! Apply adjoint at the edges of domain +! + do L=1,hz + W(:,1+L )=W(:,1+L )+W(:,1-L) + W(:,LM-L)=W(:,LM-L)+W(:,LM+L) + enddo + + do k=1,km_en + k_ind = (k-1)*Lm + do l=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)=W(k,L) + enddo + end do + + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1T_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1_bkg & +!********************************************************************** +! * +! conversion of vrbeta1 * +! * +!********************************************************************** +(this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km3,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + do k=1,km3 + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbeta(km3,hz,1,lm, pasp,ss,W) + + do k=1,km3 + k_ind =(k-1)*Lm + do L=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)= W(k,L) + end do + enddo + enddo + enddo + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1_bkg + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine sup_vrbeta1T_bkg & +!********************************************************************** +! * +! Adjoint of sup_vrbeta1_bkg * +! * +!********************************************************************** +(this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm +real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL +real(r_kind),dimension(1,1,1:lm), intent(in):: pasp +real(r_kind),dimension(1:lm), intent(in):: ss +real(r_kind),dimension(1:km3,1-hz:lm+hz):: W +integer(i_kind):: i,j,L,k,k_ind,kloc +!---------------------------------------------------------------------- + + do j=1,jm + do i=1,im + + do k=1,km3 + k_ind = (k-1)*Lm + do L=1,Lm + kloc=k_ind+L + W(k,L)=VALL(kloc,i,j) + end do + enddo + do L=1,hz + W(:,1-L )=W(:,1+L ) + W(:,LM+L)=W(:,LM-L) + end do + + call this%rbetaT(km3,hz,1,lm, pasp,ss,W) +! +! Apply adjoint at the edges of domain +! + do L=1,hz + W(:,1+L )=W(:,1+L )+W(:,1-L) + W(:,LM-L)=W(:,LM-L)+W(:,LM+L) + enddo + + do k=1,km3 + k_ind = (k-1)*Lm + do l=1,Lm + kloc=k_ind+L + VALL(kloc,i,j)=W(k,L) + enddo + end do + + end do + end do + +!---------------------------------------------------------------------- +endsubroutine sup_vrbeta1T_bkg + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_filtering diff --git a/src/mgbf/mg_generations.f90 b/src/mgbf/mg_generations.f90 new file mode 100644 index 0000000000..2008a75289 --- /dev/null +++ b/src/mgbf/mg_generations.f90 @@ -0,0 +1,1756 @@ +submodule(mg_intstate) mg_generations +!$$$ submodule documentation block +! . . . . +! module: mg_generations +! prgmmr: rancic org: NCEP/EMC date: 2022 +! +! abstract: Contains procedures that include differrent generations +! (offset version) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! upsending_all - +! downsending_all - +! weighting_all - +! upsending - +! downsending - +! upsending_highest - +! downsending_highest - +! upsending2 - +! downsending2 - +! upsending_ens - +! downsending_ens - +! upsending_ens_nearest - +! downsending_ens_nearest - +! upsending2_ens - +! downsending2_ens - +! upsending_loc_g3 - +! upsending_loc_g4 - +! downsending_loc_g3 - +! downsending_loc_g4 - +! weighting_helm - +! weighting - +! weighting_highest - +! weighting_ens - +! weighting_loc_g3 - +! weighting_loc_g4 - +! adjoint - +! direct1 - +! adjoint2 - +! direct2 - +! adjoint_nearest - +! direct_nearest - +! adjoint_highest - +! direct_highest - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +!*********************************************************************** +! ! +! ! +! M. Rancic (2022) ! +!*********************************************************************** +use mpi +use kinds, only: r_kind,i_kind +use mg_timers +!TEST +use, intrinsic:: ieee_arithmetic +!TEST + +interface weighting_loc + module procedure weighting_loc_g3 + module procedure weighting_loc_g4 +endinterface + +interface upsending_loc + module procedure upsending_loc_g3 + module procedure upsending_loc_g4 +endinterface + +interface downsending_loc + module procedure downsending_loc_g3 + module procedure downsending_loc_g4 +endinterface +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_all & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! ! +!*********************************************************************** +(this,V,H,lquart) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +logical, intent(in):: lquart +!----------------------------------------------------------------------- + + if(lquart) then + call this%upsending2(V,H) + else + call this%upsending(V,H) + endif + +!----------------------------------------------------------------------- +endsubroutine upsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_all & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,lquart) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +logical, intent(in):: lquart +!----------------------------------------------------------------------- + + if(lquart) then + call this%downsending2(H,V) + else + call this%downsending(H,V) + endif + +!----------------------------------------------------------------------- +endsubroutine downsending_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_all & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H,lhelm) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +logical, intent(in):: lhelm +!----------------------------------------------------------------------- + + if(lhelm) then + call this%weighting_helm(V,H) + else + call this%weighting(V,H) + endif + +!----------------------------------------------------------------------- +endsubroutine weighting_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) + + call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,2,2) + + call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g) + endif + + call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-1) + call this%boco_2d(H_INT,this%km,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct1(H_INT,H_PROX,this%km,g-1) + H(1:this%km,1:this%im,1:this%jm)=H (1:this%km,1:this%im,1:this%jm) & + +H_PROX(1:this%km,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km) + H(:,:,:)=0. + + call this%boco_2d(V_INT,this%km,this%imL,this%jmL,2,2) + + call this%direct1(V_INT,V_PROX,this%km,1) + + V(1:this%km,1:this%im,1:this%jm)=V (1:this%km,1:this%im,1:this%jm) & + +V_PROX(1:this%km,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_highest & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g +!----------------------------------------------------------------------- +! +! From generation 1 to higher generations +! + H(:,:,:)=0. + H(1:this%km,1:this%im0(1),1:this%jm0(1))=V(1:this%km,1:this%im0(1),1:this%jm0(1)) + do g=1,this%gm-1 + call this%adjoint_highest(H(1:this%km,1:this%im0(g),1:this%jm0(g)),& + & H_INT(1:this%km,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2),this%km,g) + H(1:this%km,1:this%im0(g),1:this%jm0(g))=0. + H(1:this%km,1:this%im0(g+1),1:this%jm0(g+1))=H_INT(1:this%km,1:this%im0(g+1),1:this%jm0(g+1)) + H_INT(1:this%km,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2)=0. + end do + +!----------------------------------------------------------------------- +endsubroutine upsending_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_highest & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,2,-1 + H_INT(1:this%km,-1:this%im0(g)+2,-1:this%jm0(g)+2)=0. + H_INT(1:this%km,1:this%im0(g),1:this%jm0(g))=H(1:this%km,1:this%im0(g),1:this%jm0(g)) + H(1:this%km,1:this%im0(g-1),1:this%jm0(g-1))=0. + call this%direct_highest(H_INT(1:this%km,-1:this%im0(g)+2,-1:this%jm0(g)+2),& + & H(1:this%km,1:this%im0(g-1),1:this%jm0(g-1)),this%km,g-1) + enddo + V(:,:,:)=0. + V(1:this%km,1:this%im0(1),1:this%jm0(1))=H(1:this%km,1:this%im0(1),1:this%jm0(1)) + H(:,:,:)=0. + +!----------------------------------------------------------------------- +endsubroutine downsending_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending2 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint2(V(1:this%km,1:this%im,1:this%jm),V_INT,this%km,1) + + call this%bocoT_2d(V_INT,this%km,this%imL,this%jmL,1,1) + + call this%upsend_all(V_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint2(H(1:this%km,1:this%im,1:this%jm),H_INT,this%km,g) + endif + + call this%bocoT_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:this%km,1:this%imL,1:this%jmL),H,this%km,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending2 & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: H_INT +real(r_kind),dimension(this%km,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(this%km,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),H_INT(1:this%km,1:this%imL,1:this%jmL),this%km,g,g-1) + call this%boco_2d(H_INT,this%km,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct2(H_INT,H_PROX,this%km,g-1) + H(1:this%km,1:this%im,1:this%jm)=H (1:this%km,1:this%im,1:this%jm) & + +H_PROX(1:this%km,1:this%im,1:this%jm) + endif + + enddo + +! +! From generation 2 to generation 1 +! + + call this%downsend_all(H(1:this%km,1:this%im,1:this%jm),V_INT(1:this%km,1:this%imL,1:this%jmL),this%km) + H(:,:,:)=0. + + call this%boco_2d(V_INT,this%km,this%imL,this%jmL,1,1) + + call this%direct2(V_INT,V_PROX,this%km,1) + + V(1:this%km,1:this%im,1:this%jm)=V (1:this%km,1:this%im,1:this%jm) & + +V_PROX(1:this%km,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_ens & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) + + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif + + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_ens & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1) + + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct1(H_INT,H_PROX,kmx,g-1) + H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) & + +H_PROX(1:kmx,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx) + H(:,:,:)=0. + + call this%boco_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%direct1(V_INT,V_PROX,kmx,1) + + V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) & + +V_PROX(1:kmx,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_ens_nearest & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint_nearest(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) + + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint_nearest(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif + + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending_ens_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_ens_nearest & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(kmx,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1) + + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct_nearest(H_INT,H_PROX,kmx,g-1) + H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) & + +H_PROX(1:kmx,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx) + H(:,:,:)=0. + + call this%boco_2d(V_INT,kmx,this%imL,this%jmL,2,2) + + call this%direct_nearest(V_INT,V_PROX,kmx,1) + + V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) & + +V_PROX(1:kmx,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_ens_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending2_ens & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend: ! +! First from g1->g2 (V -> H) ! +! Then from g2->...->gn (H -> H) ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: H_INT +integer(i_kind):: g,L +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint2(V(1:kmx,1:this%im,1:this%jm),V_INT,kmx,1) + + call this%bocoT_2d(V_INT,kmx,this%imL,this%jmL,1,1) + + call this%upsend_all(V_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx) +! +! From generation 2 sequentially to higher generations +! + do g=2,this%gm-1 + + if(g==this%my_hgen) then + call this%adjoint2(H(1:kmx,1:this%im,1:this%jm),H_INT,kmx,g) + endif + + call this%bocoT_2d(H_INT,kmx,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g,g) + + call this%upsend_all(H_INT(1:kmx,1:this%imL,1:this%jmL),H,kmx,g,g+1) + + end do + +!----------------------------------------------------------------------- +endsubroutine upsending2_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending2_ens & +!*********************************************************************** +! ! +! Downsend, interpolate and add: ! +! First from gm->g3...->g2 ! +! Then from g2->g1 ! +! ! +!*********************************************************************** +(this,H,V,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: H_INT +real(r_kind),dimension(kmx,0:this%imL+1,0:this%jmL+1):: V_INT +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(kmx,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j +!----------------------------------------------------------------------- +! +! Upper generations +! + do g=this%gm,3,-1 + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),H_INT(1:kmx,1:this%imL,1:this%jmL),kmx,g,g-1) + + call this%boco_2d(H_INT,kmx,this%imL,this%jmL,1,1,this%FimaxL,this%FjmaxL,g-1,g-1) + + if(this%my_hgen==g-1) then + call this%direct2(H_INT,H_PROX,kmx,g-1) + H(1:kmx,1:this%im,1:this%jm)=H (1:kmx,1:this%im,1:this%jm) & + +H_PROX(1:kmx,1:this%im,1:this%jm) + endif + + enddo + +! +! From geneartion 2 to generation 1 +! + + call this%downsend_all(H(1:kmx,1:this%im,1:this%jm),V_INT(1:kmx,1:this%imL,1:this%jmL),kmx) + H(:,:,:)=0. + + call this%boco_2d(V_INT,kmx,this%imL,this%jmL,1,1) + + call this%direct2(V_INT,V_PROX,kmx,1) + + V(1:kmx,1:this%im,1:this%jm)=V (1:kmx,1:this%im,1:this%jm) & + +V_PROX(1:kmx,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending2_ens + + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_loc_g3 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend for localization: ! +! ! +! First from g1->g2: V(km ) -> H(km_4) ! +! Then from g2->g3: H(km_4 ) -> Z(km_16) ! +! ! +!*********************************************************************** +(this,V,H,Z,km_in,km_4_in,km_16_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +integer(i_kind):: g,L,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:km_in,1:this%im,1:this%jm),V_INT,km_in,1) + call this%bocoT_2d(V_INT,km_in,this%imL,this%jmL,2,2) !????? + + do ind=1,1 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%upsend_loc_g12(V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),H,km_4_in,ind) + enddo + +! +! From generation 2 to generation 3 +! + + call this%adjoint(H(1:km_4_in,1:this%im,1:this%jm),H_INT,km_4_in,2) + call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%upsend_loc_g23(H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),Z,km_16_in,ind) + enddo + +!----------------------------------------------------------------------- +endsubroutine upsending_loc_g3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine upsending_loc_g4 & +!*********************************************************************** +! ! +! Adjoint interpolate and upsend for localization: ! +! ! +! First from g1->g2: V(km ) -> H(km_4) ! +! Then from g2->g3: H(km_4 ) -> Z(km_16) ! +! Then from g3->g4: Z(km_16) -> W(km_64) ! +! ! +!*********************************************************************** +(this,V,H,Z,W,km_in,km_4_in,km_16_in,km_64_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z +real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: W +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +real(r_kind),dimension(km_64_in,-1:this%imL+2,-1:this%jmL+2):: W_INT +integer(i_kind):: g,L,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 1 to generation 2 +! + + call this%adjoint(V(1:km_in,1:this%im,1:this%jm),V_INT,km_in,1) + call this%bocoT_2d(V_INT,km_in,this%imL,this%jmL,2,2) !????? + + do ind=1,4 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%upsend_loc_g12(V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),H,km_4_in,ind) + enddo + +! +! From generation 2 to generation 3 +! + + call this%adjoint(H(1:km_4_in,1:this%im,1:this%jm),H_INT,km_4_in,2) + call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%upsend_loc_g23(H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),Z,km_16_in,ind) + enddo + +! +! From generation 3 to generation 4 +! + + call this%adjoint(Z(1:km_16_in,1:this%im,1:this%jm),Z_INT,km_16_in,3) + call this%bocoT_2d_loc(H_INT,km_4_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,3) + + do ind=1,4 + k_low=km_64_in*(ind-1)+1 + k_hgh=km_64_in*ind + call this%upsend_loc_g34(Z_INT(k_low:k_hgh,1:this%imL,1:this%jmL),W,km_64_in,ind) + enddo + +!----------------------------------------------------------------------- +endsubroutine upsending_loc_g4 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_loc_g3 & +!*********************************************************************** +! ! +! Downsend, interpolate and add for localization: ! +! ! +! Then from g3->g2: Z(km_16) -> H(km_4 ) ! +! Then from g2->g1: H(km_4 ) -> V(km ) ! +! ! +!*********************************************************************** +(this,Z,H,V,km_in,km_4_in,km_16_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_16_in,1:this%im,1:this%jm):: Z_PROX +real(r_kind),dimension(km_4_in ,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(km_in ,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 3 to generation 2 +! + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%downsend_loc_g32(Z(1:km_16_in,1:this%im,1:this%jm),H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_16_in,ind) + enddo + Z(:,:,:)=0. + + call this%boco_2d_loc(H_INT,km_4_in ,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + call this%direct1(H_INT,H_PROX,km_4_in,2) + + H(1:km_4_in ,1:this%im,1:this%jm)=H (1:km_4_in ,1:this%im,1:this%jm) & + +H_PROX(1:km_4_in ,1:this%im,1:this%jm) + +! +! From geneartion 2 to generation 1 +! + do ind=1,4 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%downsend_loc_g21(H(1:km_4_in,1:this%im,1:this%jm),V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_4_in,ind) + enddo + H(:,:,:)=0. + + call this%boco_2d(V_INT,km_in,this%imL,this%jmL,2,2) + call this%direct1(V_INT,V_PROX,km_in,1) + + V(1:km_in,1:this%im,1:this%jm)=V (1:km_in,1:this%im,1:this%jm) & + +V_PROX(1:km_in,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_loc_g3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine downsending_loc_g4 & +!*********************************************************************** +! ! +! Downsend, interpolate and add for localization: ! +! ! +! First from g4->g3: W(km_16) -> Z(km_64) ! +! Then from g3->g2: Z(km_16) -> H(km_4 ) ! +! Then from g2->g1: H(km_4 ) -> V(km ) ! +! ! +!*********************************************************************** +(this,W,Z,H,V,km_in,km_4_in,km_16_in,km_64_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in +real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: W +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_64_in,-1:this%imL+2,-1:this%jmL+2):: W_INT +real(r_kind),dimension(km_16_in,-1:this%imL+2,-1:this%jmL+2):: Z_INT +real(r_kind),dimension(km_4_in ,-1:this%imL+2,-1:this%jmL+2):: H_INT +real(r_kind),dimension(km_in ,-1:this%imL+2,-1:this%jmL+2):: V_INT +real(r_kind),dimension(km_16_in,1:this%im,1:this%jm):: Z_PROX +real(r_kind),dimension(km_4_in ,1:this%im,1:this%jm):: H_PROX +real(r_kind),dimension(km_in ,1:this%im,1:this%jm):: V_PROX +integer(i_kind):: g,l,k +integer(i_kind):: iL,jL,i,j,ind,k_low,k_hgh +!----------------------------------------------------------------------- +! +! From generation 4 to generation 3 +! + do ind=1,4 + k_low=km_64_in*(ind-1)+1 + k_hgh=km_64_in*ind + call this%downsend_loc_g43(W(1:km_64_in,1:this%im,1:this%jm),Z_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_64_in,ind) + enddo + W(:,:,:)=0. + + call this%boco_2d_loc(Z_INT,km_16_in,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,3) + call this%direct1(Z_INT,Z_PROX,km_16_in,3) + + Z(1:km_16_in,1:this%im,1:this%jm)=Z (1:km_16_in,1:this%im,1:this%jm) & + +Z_PROX(1:km_16_in,1:this%im,1:this%jm) + +! +! From generation 3 to generation 2 +! + do ind=1,4 + k_low=km_16_in*(ind-1)+1 + k_hgh=km_16_in*ind + call this%downsend_loc_g32(Z(1:km_16_in,1:this%im,1:this%jm),H_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_16_in,ind) + enddo + Z(:,:,:)=0. + + call this%boco_2d_loc(H_INT,km_4_in ,this%imL,this%jmL,2,2,this%FimaxL,this%FjmaxL,2) + call this%direct1(H_INT,H_PROX,km_4_in,2) + + H(1:km_4_in ,1:this%im,1:this%jm)=H (1:km_4_in ,1:this%im,1:this%jm) & + +H_PROX(1:km_4_in ,1:this%im,1:this%jm) + +! +! From geneartion 2 to generation 1 +! + do ind=1,4 + k_low=km_4_in*(ind-1)+1 + k_hgh=km_4_in*ind + call this%downsend_loc_g21(H(1:km_4_in,1:this%im,1:this%jm),V_INT(k_low:k_hgh,1:this%imL,1:this%jmL),km_4_in,ind) + enddo + H(:,:,:)=0. + + + call this%boco_2d(V_INT,km_in,this%imL,this%jmL,2,2) + call this%direct1(V_INT,V_PROX,km_in,1) + + V(1:km_in,1:this%im,1:this%jm)=V (1:km_in,1:this%im,1:this%jm) & + +V_PROX(1:km_in,1:this%im,1:this%jm) + +!----------------------------------------------------------------------- +endsubroutine downsending_loc_g4 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_helm & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +real(r_kind),dimension(this%km,0:this%im, 1:this%jm):: DIFX +real(r_kind),dimension(this%km,1:this%im ,0:this%jm):: DIFY +real(r_kind),dimension(this%km,0:this%im, 1:this%jm):: DIFXH +real(r_kind),dimension(this%km,1:this%im ,0:this%jm):: DIFYH +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=0,this%im + DIFX(:,i,j)=V(:,i+1,j)-V(:,i,j) + enddo + enddo + do j=0,this%jm + do i=1,this%im + DIFY(:,i,j)=V(:,i,j+1)-V(:,i,j) + enddo + enddo + + do j=1,this%jm + do i=1,this%im + V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) & + -this%b_diff_f(:,i,j)*(DIFX(:,i,j)-DIFX(:,i-1,j) & + +DIFY(:,i,j)-DIFY(:,i,j-1)) + enddo + enddo + +if(this%l_hgen) then + +! imx = Fimax(my_hgen) +! jmx = Fjmax(my_hgen) + + imx = this%im + jmx = this%jm + + do j=1,jmx + do i=0,imx + DIFXH(:,i,j)=H(:,i+1,j)-H(:,i,j) + enddo + enddo + do j=0,jmx + do i=1,imx + DIFYH(:,i,j)=H(:,i,j+1)-H(:,i,j) + enddo + enddo + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) & + -this%b_diff_h(:,i,j)*(DIFXH(:,i,j)-DIFXH(:,i-1,j) & + +DIFYH(:,i,j)-DIFYH(:,i,j-1)) + enddo + enddo + +endif + +!----------------------------------------------------------------------- +endsubroutine weighting_helm + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,V,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=1,this%im + V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) + enddo + enddo + +if(this%l_hgen) then + + imx = this%im + jmx = this%jm + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +endif + +!----------------------------------------------------------------------- +endsubroutine weighting + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_highest & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable ! +! ! +!*********************************************************************** +(this,H) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +real(r_kind),dimension(this%km,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy),intent(inout):: H +integer(i_kind):: i,j,imx,jmx +!----------------------------------------------------------------------- + + imx = this%imH + jmx = this%jmH + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine weighting_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_ens & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable for ensemble ! +! ! +!*********************************************************************** +(this,V,H,kmx) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: kmx +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H +integer(i_kind):: i,j,l,k,imx,jmx +!----------------------------------------------------------------------- + +if(this%l_filt_g1) then + do j=1,this%jm + do i=1,this%im + V(:,i,j)=this%a_diff_f(:,i,j)*V(:,i,j) + enddo + enddo +else + V(:,:,:)=0. +endif + +if(this%l_hgen) then + + imx = this%im + jmx = this%jm + + do j=1,jmx + do i=1,imx + H(:,i,j)=this%a_diff_h(:,i,j)*H(:,i,j) + enddo + enddo + +endif + +!----------------------------------------------------------------------- +endsubroutine weighting_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_loc_g3 & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable in the case ! +! of localization ! +! ! +!*********************************************************************** +(this,V,H04,H16,km_in,km_4_in,km_16_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: km_in,km_4_in,km_16_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 +integer(i_kind):: i,j,l,k +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=1,this%im + V (1:km_in ,i,j)=this%w1_loc(1:km_in ,i,j)*V (1:km_in ,i,j) + H04(1:km_4_in ,i,j)=this%w2_loc(1:km_4_in ,i,j)*H04(1:km_4_in ,i,j) + H16(1:km_16_in,i,j)=this%w3_loc(1:km_16_in,i,j)*H16(1:km_16_in,i,j) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine weighting_loc_g3 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine weighting_loc_g4 & +!*********************************************************************** +! ! +! Apply 2D differential operator to compound variable in the case ! +! of localization ! +! ! +!*********************************************************************** +(this,V,H04,H16,H64,km_in,km_4_in,km_16_in,km_64_in) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind), intent(in):: km_in,km_4_in,km_16_in,km_64_in +real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V +real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 +real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 +real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H64 +integer(i_kind):: i,j,l,k +!----------------------------------------------------------------------- + + do j=1,this%jm + do i=1,this%im + V (1:km_in ,i,j)=this%w1_loc(1:km_in ,i,j)*V (1:km_in ,i,j) + H04(1:km_4_in ,i,j)=this%w2_loc(1:km_4_in ,i,j)*H04(1:km_4_in ,i,j) + H16(1:km_16_in,i,j)=this%w3_loc(1:km_16_in,i,j)*H16(1:km_16_in,i,j) + H64(1:km_64_in,i,j)=this%w4_loc(1:km_64_in,i,j)*H64(1:km_64_in,i,j) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine weighting_loc_g4 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm-mod(this%jm,2),2,-2 + jL = j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%p_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%p_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%p_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%p_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm-1+mod(this%jm,2),1,-2 + jL=j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%q_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%q_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%q_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%q_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jmL+2,-1,-1 + do i=this%im-1+mod(this%im,2),1,-2 + iL = i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%q_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%q_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%q_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%q_coef(1)*W_AUX(:,i,jL) + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%p_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%p_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%p_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%p_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct1 & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=-1,this%jmL+2 + do i=1,this%im-1+mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=this%q_coef(1)*W(:,iL-1,jL)+this%q_coef(2)*W(:,iL ,jL) & + +this%q_coef(3)*W(:,iL+1,jL)+this%q_coef(4)*W(:,iL+2,jL) + enddo + do i=2,this%im-mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=this%p_coef(1)*W(:,iL-1,jL)+this%p_coef(2)*w(:,iL ,jL) & + +this%p_coef(3)*W(:,iL+1,jL)+this%p_coef(4)*W(:,iL+2,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm-1+mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=this%q_coef(1)*W_AUX(:,i,jL-1)+this%q_coef(2)*W_AUX(:,i,jL ) & + +this%q_coef(3)*W_AUX(:,i,jL+1)+this%q_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo +! +! 3) +! + do j=2,this%jm-mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=this%p_coef(1)*W_AUX(:,i,jL-1)+this%p_coef(2)*W_AUX(:,i,jL ) & + +this%p_coef(3)*W_AUX(:,i,jL+1)+this%p_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct1 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint2 & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using quadratics interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F +real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(out):: W +real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm-mod(this%jm,2),2,-2 + jL = j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%b_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%b_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%b_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm-1+mod(this%jm,2),1,-2 + jL=(j+1)/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%a_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%a_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%a_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jmL+1,0,-1 + do i=this%im-1+mod(this%im,2),1,-2 + iL = (i+1)/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+this%a_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%a_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%a_coef(1)*W_AUX(:,i,jL) + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+this%b_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%b_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%b_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct2 & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using quadratic interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(in):: W +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F +real(r_kind), dimension(km_in,1:this%im,0:this%jmL+1):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=0,this%jmL+1 + do i=1,this%im-1+mod(this%im,2),2 + iL=(i+1)/2 + W_AUX(:,i,jL)=this%a_coef(1)*W(:,iL-1,jL)+this%a_coef(2)*W(:,iL ,jL) & + +this%a_coef(3)*W(:,iL+1,jL) + enddo + do i=2,this%im-mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=this%b_coef(1)*W(:,iL-1,jL)+this%b_coef(2)*w(:,iL ,jL) & + +this%b_coef(3)*W(:,iL+1,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm-1+mod(this%jm,2),2 + jL=(j+1)/2 + do i=1,this%im + F(:,i,j)=this%a_coef(1)*W_AUX(:,i,jL-1)+this%a_coef(2)*W_AUX(:,i,jL ) & + +this%a_coef(3)*W_AUX(:,i,jL+1) + enddo + enddo +! +! 3) +! + do j=2,this%jm-mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=this%b_coef(1)*W_AUX(:,i,jL-1)+this%b_coef(2)*W_AUX(:,i,jL ) & + +this%b_coef(3)*W_AUX(:,i,jL+1) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint_nearest & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! selecting the nearest point ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm-mod(this%jm,2),2,-2 + jL = j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL )=W_AUX(:,i,jL )+0.5**0.5*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm-1+mod(this%jm,2),1,-2 + jL=j/2 + do i=this%im,1,-1 + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+0.5**0.5*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jmL+2,-1,-1 + do i=this%im-1+mod(this%im,2),1,-2 + iL = i/2 + W(:,iL+1,jL)=W(:,iL+1,jL)+0.5**0.5*W_AUX(:,i,jL) + enddo + do i=this%im-mod(this%im,2),2,-2 + iL=i/2 + W(:,iL ,jL)=W(:,iL ,jL)+0.5**0.5*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct_nearest & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! selecting the nearest point ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W +real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F +real(r_kind), dimension(km_in,1:this%im,-1:this%jmL+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=-1,this%jmL+2 + do i=1,this%im-1+mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=0.5**0.5*W(:,iL+1,jL) + enddo + do i=2,this%im-mod(this%im,2),2 + iL=i/2 + W_AUX(:,i,jL)=0.5**0.5*w(:,iL ,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm-1+mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=0.5**0.5*W_AUX(:,i,jL+1) + enddo + enddo +! +! 3) +! + do j=2,this%jm-mod(this%jm,2),2 + jL=j/2 + do i=1,this%im + F(:,i,j)=0.5**0.5*W_AUX(:,i,jL ) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct_nearest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine adjoint_highest & +!*********************************************************************** +! ! +! Mapping from the high to low resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,F,W,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(in):: F +real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(out):: W +real(r_kind), dimension(km_in,1:this%im0(g),-1:this%jm0(g+1)+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 3) +! + W_AUX(:,:,:)= 0. + + do j=this%jm0(g)-mod(this%jm0(g),2),2,-2 + jL = j/2 + do i=this%im0(g),1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%p_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%p_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%p_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%p_coef(1)*F(:,i,j) + enddo + enddo +! +! 2) +! + do j=this%jm0(g)-1+mod(this%jm0(g),2),1,-2 + jL=j/2 + do i=this%im0(g),1,-1 + W_AUX(:,i,jL+2)=W_AUX(:,i,jL+2)+this%q_coef(4)*F(:,i,j) + W_AUX(:,i,jL+1)=W_AUX(:,i,jL+1)+this%q_coef(3)*F(:,i,j) + W_AUX(:,i,jL )=W_AUX(:,i,jL )+this%q_coef(2)*F(:,i,j) + W_AUX(:,i,jL-1)=W_AUX(:,i,jL-1)+this%q_coef(1)*F(:,i,j) + enddo + enddo + + W(:,:,:)=0. +! +! 1) +! + do jL=this%jm0(g+1)+2,-1,-1 + do i=this%im0(g)-1+mod(this%im0(g),2),1,-2 + iL = i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%q_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%q_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%q_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%q_coef(1)*W_AUX(:,i,jL) + enddo + do i=this%im0(g)-mod(this%im0(g),2),2,-2 + iL=i/2 + W(:,iL+2,jL)=W(:,iL+2,jL)+this%p_coef(4)*W_AUX(:,i,jL) + W(:,iL+1,jL)=W(:,iL+1,jL)+this%p_coef(3)*W_AUX(:,i,jL) + W(:,iL ,jL)=W(:,iL ,jL)+this%p_coef(2)*W_AUX(:,i,jL) + W(:,iL-1,jL)=W(:,iL-1,jL)+this%p_coef(1)*W_AUX(:,i,jL) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine adjoint_highest + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine direct_highest & +!*********************************************************************** +! ! +! Mapping from the low to high resolution grid ! +! using linearly squared interpolations ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,F,km_in,g) +!----------------------------------------------------------------------- +implicit none +class (mg_intstate_type),target:: this +integer(i_kind),intent(in):: g +integer(i_kind),intent(in):: km_in +real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(in):: W +real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(out):: F +real(r_kind), dimension(km_in,1:this%im0(g),-1:this%jm0(g+1)+2):: W_AUX +integer(i_kind):: i,j,iL,jL +!----------------------------------------------------------------------- +! +! 1) +! + do jL=-1,this%jm0(g+1)+2 + do i=1,this%im0(g)-1+mod(this%im0(g),2),2 + iL=i/2 + W_AUX(:,i,jL)=this%q_coef(1)*W(:,iL-1,jL)+this%q_coef(2)*W(:,iL ,jL) & + +this%q_coef(3)*W(:,iL+1,jL)+this%q_coef(4)*W(:,iL+2,jL) + enddo + do i=2,this%im0(g)-mod(this%im0(g),2),2 + iL=i/2 + W_AUX(:,i,jL)=this%p_coef(1)*W(:,iL-1,jL)+this%p_coef(2)*w(:,iL ,jL) & + +this%p_coef(3)*W(:,iL+1,jL)+this%p_coef(4)*W(:,iL+2,jL) + enddo + enddo +! +! 2) +! + do j=1,this%jm0(g)-1+mod(this%jm0(g),2),2 + jL=j/2 + do i=1,this%im0(g) + F(:,i,j)=this%q_coef(1)*W_AUX(:,i,jL-1)+this%q_coef(2)*W_AUX(:,i,jL ) & + +this%q_coef(3)*W_AUX(:,i,jL+1)+this%q_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo +! +! 3) +! + do j=2,this%jm0(g)-mod(this%jm0(g),2),2 + jL=j/2 + do i=1,this%im0(g) + F(:,i,j)=this%p_coef(1)*W_AUX(:,i,jL-1)+this%p_coef(2)*W_AUX(:,i,jL ) & + +this%p_coef(3)*W_AUX(:,i,jL+1)+this%p_coef(4)*W_AUX(:,i,jL+2) + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine direct_highest + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_generations diff --git a/src/mgbf/mg_input.f90 b/src/mgbf/mg_input.f90 new file mode 100644 index 0000000000..80b0772c12 --- /dev/null +++ b/src/mgbf/mg_input.f90 @@ -0,0 +1,155 @@ +module mg_input +!$$$ submodule documentation block +! . . . . +! module: mg_input +! prgmmr: rancic org: NCEP/EMC date: +! +! abstract: Module for data input +! (Here will be defined uniform decomposition and padding +! with zeros of control variables, required by the filter) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! input_2d - +! input_spec1_2d - +! input_3d - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi + +use mg_intstate, only : mg_intstate_type +public input_2d +public input_spec1_2d +public input_3d + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine input_2d & +!*********************************************************************** +! ! +! Define some function for testing redecomposition ! +! (for analysis grid) ! +! ! +!*********************************************************************** +(obj_intstate,V,imin,jmin,imax,jmax,imax0,ampl) +!----------------------------------------------------------------------- +use kinds, only: r_kind,i_kind +implicit none +class (mg_intstate_type):: obj_intstate +integer(i_kind),intent(in):: imax,jmax +integer(i_kind),intent(in):: imin,jmin +integer(i_kind),intent(in):: imax0 +integer(i_kind),intent(in):: ampl +real(r_kind),dimension(imin:imax,jmin:jmax),intent(out):: V +real(i_kind):: ng,mg,L,m,n +!----------------------------------------------------------------------- + + do m=imin,jmax + mg = (obj_intstate%my-1)*jmax+m + do n=jmin,imax + ng = (obj_intstate%nx-1)*imax+n + V(n,m)=ampl*(mg*imax0+ng) +! V(n,m)=0. + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine input_2d + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine input_spec1_2d & +!*********************************************************************** +! ! +! Define some function for testing redecomposition ! +! (for analysis grid) ! +! ! +!*********************************************************************** +(obj_intstate,V,nx0,my0,flag) +!----------------------------------------------------------------------- +use kinds, only: r_kind,i_kind +implicit none +class (mg_intstate_type):: obj_intstate +integer(i_kind),intent(in):: nx0,my0 +real(r_kind),dimension(1:obj_intstate%nm,1:obj_intstate%mm),intent(out):: V +character(len=2), intent(in):: flag +integer(r_kind):: v0=1. +!----------------------------------------------------------------------- + + V(:,:)=0. + +if(flag=='md') then + if(obj_intstate%nx==nx0.and.obj_intstate%my==my0) then + V(obj_intstate%nm/2,obj_intstate%mm/2)=v0 + endif +else & +if(flag=='rt') then + if(obj_intstate%nx==nx0.and.obj_intstate%my==my0) then + V(obj_intstate%nm,obj_intstate%mm)=v0 + endif + if(obj_intstate%nx==nx0+1.and.obj_intstate%my==my0) then + V(1,obj_intstate%mm)=v0 + endif + if(obj_intstate%nx==nx0.and.obj_intstate%my==my0+1) then + V(obj_intstate%nm,1)=v0 + endif + if(obj_intstate%nx==nx0+1.and.obj_intstate%my==my0+1) then + V(1,1)=v0 + endif +endif + +!----------------------------------------------------------------------- +endsubroutine input_spec1_2d + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine input_3d & +!*********************************************************************** +! ! +! Define some function for testing redecomposition ! +! (for analysis grid) ! +! ! +!*********************************************************************** +(obj_intstate,V,imin,jmin,lmin,imax,jmax,lmax,imax0,ampl,incrm) +!----------------------------------------------------------------------- +use kinds, only: r_kind,i_kind +implicit none +class (mg_intstate_type):: obj_intstate +integer(i_kind),intent(in):: imin,jmin,lmin +integer(i_kind),intent(in):: imax,jmax,lmax +integer(i_kind),intent(in):: imax0 +integer(i_kind),intent(in):: ampl,incrm +real(r_kind),dimension(lmin:lmax,imin:imax,jmin:jmax),intent(out):: V +real(i_kind):: ng,mg,L,m,n +!----------------------------------------------------------------------- + + do l=lmin,lmax + do m=imin,jmax + mg = (obj_intstate%my-1)*jmax+m + do n=jmin,imax + ng = (obj_intstate%nx-1)*imax+n + V(l,n,m)=ampl*(mg*imax0+ng) +(l-1)*incrm +! V(l,n,m)=0. + enddo + enddo + enddo + +!----------------------------------------------------------------------- +endsubroutine input_3d + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module mg_input diff --git a/src/mgbf/mg_interpolate.f90 b/src/mgbf/mg_interpolate.f90 new file mode 100644 index 0000000000..3a73ef6b3b --- /dev/null +++ b/src/mgbf/mg_interpolate.f90 @@ -0,0 +1,1017 @@ +submodule(mg_intstate) mg_interpolate +!$$$ submodule documentation block +! . . . . +! module: mg_interpolate +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: General mapping between 2d arrays using linerly squared +! interpolations +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! def_offset_coef - +! lsqr_mg_coef - +! lwq_vertical_coef - +! lwq_vertical_adjoint - +! lwq_vertical_direct - +! lwq_vertical_adjoint_spec - +! lwq_vertical_direct_spec - +! l_vertical_adjoint_spec - +! l_vertical_direct_spec - +! lsqr_direct_offset - +! lsqr_adjoint_offset - +! quad_direct_offset - +! quad_adjoint_offset - +! lin_direct_offset - +! lin_adjoint_offset - +! l_vertical_adjoint_spec2 - +! l_vertical_direct_spec2 - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds +use jp_pkind2, only: fpi + +implicit none +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine def_offset_coef (this) +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this + +real(r_kind):: r64,r32,r128 +!----------------------------------------------------------------------- + r64 = 1.0d0/64.0d0 + r32 = 1.0d0/32.0d0 + r128= 1.0d0/128.0d0 + +! p_coef =(/-3.,51,29,-3/) +! q_coef =(/-3.,19.0d0,51.0d0,-3.0d0/) +! p_coef = p_coef*r64 +! q_coef = q_coef*r64 + + this%p_coef =(/-9.,111.,29.,-3./) + this%q_coef =(/-3.,29.,111.,-9./) + this%p_coef = this%p_coef*r128 + this%q_coef = this%q_coef*r128 + + this%a_coef =(/5.,30.,-3./) + this%b_coef =(/-3.,30.,5./) + this%a_coef=this%a_coef*r32 + this%b_coef=this%b_coef*r32 +!----------------------------------------------------------------------- +endsubroutine def_offset_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lsqr_mg_coef (this) +!*********************************************************************** +! ! +! Prepare coeficients for mapping between: ! +! filter grid on analysis decomposition: W(1-ib:im+ib,1-jb:jm+jb) ! +! and analysis grid: V(1:nm,1:mm) ! +! - offset version - ! +! ! +! ( im < nm and jm < mm ) ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind), dimension(1:this%nm):: xa +real(r_kind), dimension(1-this%ib:this%im+this%ib):: xf +real(r_kind), dimension(1:this%mm):: ya +real(r_kind), dimension(1-this%jb:this%jm+this%jb):: yf +integer(i_kind):: i,j,n,m +real(r_kind) x1,x2,x3,x4,x +real(r_kind) x1x,x2x,x3x,x4x +real(r_kind) rx2x1,rx3x1,rx4x1,rx3x2,rx4x2,rx4x3 +real(r_kind) y1,y2,y3,y4,y +real(r_kind) y1y,y2y,y3y,y4y +real(r_kind) ry2y1,ry3y1,ry4y1,ry3y2,ry4y2,ry4y3 +real(r_kind) cfl1,cfl2,cfl3,cll +real(r_kind) cfr1,cfr2,cfr3,crr +real(r_kind) x1_x,x2_x,x3_x +real(r_kind) y1_y,y2_y,y3_y +!----------------------------------------------------------------------- +! +! Initialize +! + + do n=1,this%nm + xa(n)=this%xa0+this%dxa*(n-1) + enddo + + do i=1-this%ib,this%im+this%ib + xf(i)=this%xf0+this%dxf*(i-1) + enddo + + do m=1,this%mm + ya(m)=this%ya0+this%dya*(m-1) + enddo + + do j=1-this%jb,this%jm+this%jb + yf(j)=this%yf0+this%dyf*(j-1) + enddo + +! +! Find iref and jref +! + do n=1,this%nm + do i=1-this%ib,this%im+this%ib-1 + if( xa(n)< xf(i)) then + this%iref(n)=i-2 + this%irefq(n)=i-1 + this%irefL(n)=i-1 + exit + endif + enddo + enddo + + do m=1,this%mm + do j=1-this%jb,this%jm+this%jb-1 + if(ya(m) < yf(j)) then + this%jref(m)=j-2 + this%jrefq(m)=j-1 + this%jrefL(m)=j-1 + exit + endif + enddo + enddo + + do n=1,this%nm + i=this%iref(n) + x1=xf(i) + x2=xf(i+1) + x3=xf(i+2) + x4=xf(i+3) + x = xa(n) + x1x = x1-x + x2x = x2-x + x3x = x3-x + x4x = x4-x + rx2x1 = 1./(x2-x1) + rx3x1 = 1./(x3-x1) + rx4x1 = 1./(x4-x1) + rx3x2 = 1./(x3-x2) + rx4x2 = 1./(x4-x2) + rx4x3 = 1./(x4-x3) + CFL1 = x2x*x3x*rx2x1*rx3x1 + CFL2 =-x1x*x3x*rx2x1*rx3x2 + CFL3 = x1x*x2x*rx3x1*rx3x2 + CLL = x3x*rx3x2 + CFR1 = x3x*x4x*rx3x2*rx4x2 + CFR2 =-x2x*x4x*rx3x2*rx4x3 + CFR3 = x2x*x3x*rx4x2*rx4x3 + CRR =-x2x*rx3x2 + this%cx0(n)=CFL1*CLL + this%cx1(n)=CFL2*CLL+CFR1*CRR + this%cx2(n)=CFL3*CLL+CFR2*CRR + this%cx3(n)=CFR3*CRR + enddo + + do m=1,this%mm + j=this%jref(m) + y1=yf(j) + y2=yf(j+1) + y3=yf(j+2) + y4=yf(j+3) + y = ya(m) + y1y = y1-y + y2y = y2-y + y3y = y3-y + y4y = y4-y + ry2y1 = 1./(y2-y1) + ry3y1 = 1./(y3-y1) + ry4y1 = 1./(y4-y1) + ry3y2 = 1./(y3-y2) + ry4y2 = 1./(y4-y2) + ry4y3 = 1./(y4-y3) + CFL1 = y2y*y3y*ry2y1*ry3y1 + CFL2 =-y1y*y3y*ry2y1*ry3y2 + CFL3 = y1y*y2y*ry3y1*ry3y2 + CLL = y3y*ry3y2 + CFR1 = y3y*y4y*ry3y2*ry4y2 + CFR2 =-y2y*y4y*ry3y2*ry4y3 + CFR3 = y2y*y3y*ry4y2*ry4y3 + CRR =-y2y*ry3y2 + this%cy0(m)=CFL1*CLL + this%cy1(m)=CFL2*CLL+CFR1*CRR + this%cy2(m)=CFL3*CLL+CFR2*CRR + this%cy3(m)=CFR3*CRR + enddo + +! +! Quadratic interpolations +! + do n=1,this%nm + i=this%irefq(n) + x1=xf(i) + x2=xf(i+1) + x3=xf(i+2) + x = xa(n) + x1_x = x1-x + x2_x = x2-x + x3_x = x3-x + rx2x1 = 1./(x2-x1) + rx3x1 = 1./(x3-x1) + rx3x2 = 1./(x3-x2) + this%qx0(n) = x2_x*x3_x*rx2x1*rx3x1 + this%qx1(n) =-x1_x*x3_x*rx2x1*rx3x2 + this%qx2(n) = x1_x*x2_x*rx3x1*rx3x2 + enddo + + do m=1,this%mm + i=this%jrefq(m) + y1=yf(i) + y2=yf(i+1) + y3=yf(i+2) + y = ya(m) + y1_y = y1-y + y2_y = y2-y + y3_y = y3-y + ry2y1 = 1./(y2-y1) + ry3y1 = 1./(y3-y1) + ry3y2 = 1./(y3-y2) + this%qy0(m) = y2_y*y3_y*ry2y1*ry3y1 + this%qy1(m) =-y1_y*y3_y*ry2y1*ry3y2 + this%qy2(m) = y1_y*y2_y*ry3y1*ry3y2 + enddo + +! +! Linear interpolations +! + do n=1,this%nm + i=this%irefL(n) + x1=xf(i) + x2=xf(i+1) + x = xa(n) + x1_x = x1-x + x2_x = x2-x + rx2x1 = 1./(x2-x1) + this%Lx0(n) = x2_x*rx2x1 + this%Lx1(n) =-x1_x*rx2x1 + enddo + + do m=1,this%mm + j=this%jrefL(m) + y1=yf(j) + y2=yf(j+1) + y = ya(m) + y1_y = y1-y + y2_y = y2-y + ry2y1 = 1./(y2-y1) + this%Ly0(m) = y2_y*ry2y1 + this%Ly1(m) =-y1_y*ry2y1 + enddo +!----------------------------------------------------------------------- +endsubroutine lsqr_mg_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_coef & +!*********************************************************************** +! ! +! Prepare coeficients for vertical mapping between: ! +! analysis grid vertical resolution (nm) and ! +! generation one of filter grid vertical resoluition (im) ! +! ! +! ( im <= nm ) ! +! ! +!*********************************************************************** +(this,nm_in,im_in,c1,c2,c3,c4,iref_out) +implicit none +class(mg_intstate_type),target::this + +integer(i_kind), intent(in):: nm_in,im_in +real(r_kind), dimension(1:nm_in), intent(out):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(out):: iref_out + +real(r_kind), dimension(1:nm_in):: y +real(r_kind), dimension(0:im_in+1):: x +real(r_kind):: dy,x1,x2,x3,x4,dx1,dx2,dx3,dx4 +real(r_kind):: dx13,dx23,dx24 + +integer(i_kind):: i,n +!----------------------------------------------------------------------- + + do i=0,im_in+1 + x(i)=(i-1)*1. + enddo + + dy = 1.*(im_in-1)/(nm_in-1) + do n=1,nm_in + y(n)=(n-1)*dy + enddo + y(nm_in)=x(im_in) + + do n=2,nm_in-1 + i = y(n)+1 + x1 = x(i-1) + x2 = x(i) + x3 = x(i+1) + x4 = x(i+2) + iref_out(n)=i + dx1 = y(n)-x1 + dx2 = y(n)-x2 + dx3 = y(n)-x3 + dx4 = y(n)-x4 + dx13 = dx1*dx3 + dx23 = 0.5*dx2*dx3 + dx24 = dx2*dx4 + c1(n) = -dx23*dx3 + c2(n) = ( dx13+0.5*dx24)*dx3 + c3(n) = -(0.5*dx13+ dx24)*dx2 + c4(n) = dx23*dx2 + + if(iref_out(n)==1) then + c3(n)=c3(n)+c1(n) + c1(n)=0. + endif + if(iref_out(n)==im_in-1) then + c2(n)=c2(n)+c4(n) + c4(n)=0. + endif + enddo + iref_out(1)=1; c1(1)=0.; c2(1)=1.; c3(1)=0.; c4(1)=0. + iref_out(nm_in)=im_in; c1(nm_in)=0.; c2(nm_in)=1.; c3(nm_in)=0.; c4(n)=0. + +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_coef + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_adjoint & +!*********************************************************************** +! ! +! Direct linerly weighted quadratic adjoint interpolation in vertical ! +! from reslution nm to resolution km ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(in):: w +real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(out):: f +integer(i_kind):: k,n +!----------------------------------------------------------------------- + f = 0. +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + f(1,:,:) = f(1,:,:)+c2(n)*w(n,:,:) + f(2,:,:) = f(2,:,:)+c3(n)*w(n,:,:) + f(3,:,:) = f(3,:,:)+c4(n)*w(n,:,:) + elseif & + ( k==km_in-1) then + f(km_in-2,:,:) = f(km_in-2,:,:)+c1(n)*w(n,:,:) + f(km_in-1,:,:) = f(km_in-1,:,:)+c2(n)*w(n,:,:) + f(km_in ,:,:) = f(km_in ,:,:)+c3(n)*w(n,:,:) + elseif( k==km_in) then + f(k ,:,:) = f(k ,:,:)+c2(n)*w(n,:,:) + else + f(k-1,:,:) = f(k-1,:,:)+c1(n)*w(n,:,:) + f(k ,:,:) = f(k ,:,:)+c2(n)*w(n,:,:) + f(k+1,:,:) = f(k+1,:,:)+c3(n)*w(n,:,:) + f(k+2,:,:) = f(k+2,:,:)+c4(n)*w(n,:,:) + endif +enddo + f(1,:,:)=f(1,:,:)+w(1,:,:) + f(km_in,:,:)=f(km_in,:,:)+w(nm_in,:,:) + +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_adjoint + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_direct & +!*********************************************************************** +! ! +! Linerly weighted direct quadratic interpolation in vertical ! +! from reslouion km to resolution nm ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(in):: f +real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(out):: w +integer(i_kind):: k,n +!----------------------------------------------------------------------- +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + w(n,:,:) = c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:)+c4(n)*f(k+2,:,:) + elseif & + ( k==km_in-1) then + w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,:)+c3(n)*f(k+1,:,:) + elseif & + ( k==km_in) then + w(n,:,:) = c2(n)*f(k,:,:) + else + w(n,:,:) =c1(n)*f(k-1,:,:)+c2(n)*f(k,:,: )+c3(n)*f(k+1,:,:)+c4(n)*f(k+2,:,:) + endif +enddo + w(1,:,:)=f(1,:,:) + w(nm_in,:,:)=f(km_in,:,:) + +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_direct + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_adjoint_spec & +!*********************************************************************** +! ! +! Direct linerly weighted quadratic adjoint interpolation in vertical ! +! from reslution nm to resolution km ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,W,F) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F +integer(i_kind):: k,n +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(n,k) + F = 0. +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + F(:,:,:,1) = F(:,:,:,1)+c2(n)*W(:,:,:,n) + F(:,:,:,2) = F(:,:,:,2)+c3(n)*W(:,:,:,n) + F(:,:,:,3) = F(:,:,:,3)+c4(n)*W(:,:,:,n) + elseif & + ( k==km_in-1) then + F(:,:,:,km_in-2) = F(:,:,:,km_in-2)+c1(n)*W(:,:,:,n) + F(:,:,:,km_in-1) = F(:,:,:,km_in-1)+c2(n)*W(:,:,:,n) + F(:,:,:,km_in ) = F(:,:,:,km_in )+c3(n)*W(:,:,:,n) + elseif( k==km_in) then + F(:,:,:,k ) = F(:,:,:,k )+c2(n)*W(:,:,:,n) + else + F(:,:,:,k-1) = F(:,:,:,k-1)+c1(n)*W(:,:,:,n) + F(:,:,:,k ) = F(:,:,:,k )+c2(n)*W(:,:,:,n) + F(:,:,:,k+1) = F(:,:,:,k+1)+c3(n)*W(:,:,:,n) + F(:,:,:,k+2) = F(:,:,:,k+2)+c4(n)*W(:,:,:,n) + endif +enddo + F(:,:,:,1 )=F(:,:,:,1 )+W(:,:,:,1 ) + F(:,:,:,km_in)=F(:,:,:,km_in)+W(:,:,:,nm_in) + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_adjoint_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lwq_vertical_direct_spec & +!*********************************************************************** +! ! +! Linerly weighted direct quadratic interpolation in vertical ! +! from reslouion im to resolution nm ! +! ! +! ( km <= nm ) ! +! ! +!*********************************************************************** +(this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,F,W) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 +integer(i_kind), dimension(1:nm_in), intent(in):: kref +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W +integer(i_kind):: k,n +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(n,k) + +do n=2,nm_in-1 + k = kref(n) + if( k==1 ) then + W(:,:,:,n) = c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)+c4(n)*F(:,:,:,k+2) + elseif & + ( k==km_in-1) then + W(:,:,:,n) =c1(n)*F(:,:,:,k-1)+c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1) + elseif & + ( k==km_in) then + W(:,:,:,n) = c2(n)*F(:,:,:,k) + else + W(:,:,:,n) =c1(n)*F(:,:,:,k-1)+c2(n)*F(:,:,:,k)+c3(n)*F(:,:,:,k+1)+c4(n)*F(:,:,:,k+2) + endif +enddo + W(:,:,:,1 )=F(:,:,:,1 ) + W(:,:,:,nm_in)=F(:,:,:,km_in) + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine lwq_vertical_direct_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_adjoint_spec & +!*********************************************************************** +! ! +! Adjoint of linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nm = 2*km-1 ) ! +! ! +!*********************************************************************** +(this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,W,F) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F +integer(i_kind):: k,n +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(n,k) + F = 0. + + k=1 + do n=2,nm_in-1,2 + F(:,:,:,k ) = F(:,:,:,k )+0.5*W(:,:,:,n) + F(:,:,:,k+1) = F(:,:,:,k+1)+0.5*W(:,:,:,n) + k=k+1 + enddo + + k=1 + do n=1,nm_in,2 + F(:,:,:,k ) = F(:,:,:,k )+ W(:,:,:,n) + k=k+1 + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine l_vertical_adjoint_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_direct_spec & +!*********************************************************************** +! ! +! ! +! Direct linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nm = 2*km-1 ) ! +! ! +!*********************************************************************** +(this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,F,W) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F +real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W +integer(i_kind):: k,n +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(n,k) + + k=1 + do n=1,nm_in,2 + W(:,:,:,n) =F (:,:,:,k) + k=k+1 + enddo + + k=1 + do n=2,nm_in-1,2 + W(:,:,:,n) = 0.5*(F(:,:,:,k)+F(:,:,:,k+1)) + k=k+1 + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine l_vertical_direct_spec + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lsqr_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! +! using two passes of 1d interpolator ! +! ! +!*********************************************************************** +(this,V_in,W,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km_in):: v0,v1,v2,v3 +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(j,n,i,v0,v1,v2,v3) + + do j=1-jbm,this%jm+jbm + do n=1,this%nm + i = this%iref(n) + v0(:)=V_in(:,i ,j) + v1(:)=V_in(:,i+1,j) + v2(:)=V_in(:,i+2,j) + v3(:)=V_in(:,i+3,j) + VX(:,n,j) = this%cx0(n)*v0(:)+this%cx1(n)*v1(:)+this%cx2(n)*v2(:)+this%cx3(n)*v3(:) + enddo + enddo + + do m=1,this%mm + j = this%jref(m) + do n=1,this%nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + v2(:)=VX(:,n,j+2) + v3(:)=VX(:,n,j+3) + W(:,n,m) = this%cy0(m)*v0(:)+this%cy1(m)*v1(:)+this%cy2(m)*v2(:)+this%cy3(m)*v3(:) + enddo + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine lsqr_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lsqr_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,1:nm,1:mm) perform adjoint ! +! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) ! +! using two passes of 1d interpolator ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,V_out,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +real(r_kind), dimension(km_in):: wk +real(r_kind), dimension(km_in):: vxk +integer(i_kind):: i,j,n,m,l,k +real(r_kind):: c0,c1,c2,c3 +!----------------------------------------------------------------------- + V_out(:,:,:)=0. + VX(:,:,:)=0. + +!$OMP PARALLEL PRIVATE(j,m,n,i,c0,c1,c2,c3,wk,vxk) + + do m=1,this%mm + j = this%jref(m) + c0 = this%cy0(m) + c1 = this%cy1(m) + c2 = this%cy2(m) + c3 = this%cy3(m) + do n=1,this%nm + wk(:)=W(:,n,m) + VX(:,n,j ) = VX(:,n,j )+wk(:)*c0 + VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1 + VX(:,n,j+2) = VX(:,n,j+2)+wk(:)*c2 + VX(:,n,j+3) = VX(:,n,j+3)+wk(:)*c3 + enddo + enddo + + do n=1,this%nm + i = this%iref(n) + c0 = this%cx0(n) + c1 = this%cx1(n) + c2 = this%cx2(n) + c3 = this%cx3(n) + do j=1-jbm,this%jm+jbm + vxk(:)=VX(:,n,j) + V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0 + V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 + V_out(:,i+2,j) = V_out(:,i+2,j)+vxk(:)*c2 + V_out(:,i+3,j) = V_out(:,i+3,j)+vxk(:)*c3 + enddo + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine lsqr_adjoint_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine quad_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! +! using two passes of 1d interpolator ! +! ! +!*********************************************************************** +(this,V_in,W,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km_in):: v0,v1,v2 +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(i,j,n,m,v0,v1,v2) + + do n=1,this%nm + i = this%irefq(n) + do j=1-jbm,this%jm+jbm + v0(:)=V_in(:,i ,j) + v1(:)=V_in(:,i+1,j) + v2(:)=V_in(:,i+2,j) + VX(:,n,j) = this%qx0(n)*v0(:)+this%qx1(n)*v1(:)+this%qx2(n)*v2(:) + enddo + enddo + + do m=1,this%mm + j = this%jrefq(m) + do n=1,this%nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + v2(:)=VX(:,n,j+2) + W(:,n,m) = this%qy0(m)*v0(:)+this%qy1(m)*v1(:)+this%qy2(m)*v2(:) + enddo + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine quad_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine quad_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,1:nm,1:mm) perform adjoint ! +! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) ! +! using two passes of 1d interpolator ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,V_out,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +real(r_kind), dimension(km_in):: wk +real(r_kind), dimension(km_in):: vxk +integer(i_kind):: i,j,n,m,l,k +real(r_kind):: c0,c1,c2 +!----------------------------------------------------------------------- + V_out(:,:,:)=0. + VX(:,:,:)=0. + +!$OMP PARALLEL PRIVATE(j,m,n,i,c0,c1,c2,wk,vxk) + + do m=1,this%mm + j = this%jrefq(m) + c0 = this%qy0(m) + c1 = this%qy1(m) + c2 = this%qy2(m) + do n=1,this%nm + wk(:)=W(:,n,m) + VX(:,n,j ) = VX(:,n,j )+wk(:)*c0 + VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1 + VX(:,n,j+2) = VX(:,n,j+2)+wk(:)*c2 + enddo + enddo + + + do n=1,this%nm + i = this%irefq(n) + c0 = this%qx0(n) + c1 = this%qx1(n) + c2 = this%qx2(n) + do j=1-jbm,this%jm+jbm + vxk(:)=VX(:,n,j) + V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0 + V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 + V_out(:,i+2,j) = V_out(:,i+2,j)+vxk(:)*c2 + enddo + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine quad_adjoint_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lin_direct_offset & +!*********************************************************************** +! ! +! Given a source array V(km,1-ib:im+ib,1-jb:jm+jb) perform ! +! direct interpolations to get target array W(km,1:nm,1:mm) ! +! using two passes of 1d linear interpolator ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,V_in,W,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind),intent(in):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +integer(i_kind):: i,j,n,m +real(r_kind),dimension(km_in):: v0,v1 +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(i,j,n,m,v0,v1) + + do n=1,this%nm + i = this%irefL(n) + do j=1-jbm,this%jm+jbm + v0(:)=V_in(:,i ,j) + v1(:)=V_in(:,i+1,j) + VX(:,n,j) = this%Lx0(n)*v0(:)+this%Lx1(n)*v1(:) + enddo + enddo + + do m=1,this%mm + j = this%jrefL(m) + do n=1,this%nm + v0(:)=VX(:,n,j ) + v1(:)=VX(:,n,j+1) + W(:,n,m) = this%Ly0(m)*v0(:)+this%Ly1(m)*v1(:) + enddo + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine lin_direct_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine lin_adjoint_offset & +!*********************************************************************** +! ! +! Given a target array W(km,1:nm,1:mm) perform adjoint ! +! interpolations to get source array V(km,1-ib:im+ib,1-jb:jm+jb) ! +! using two passes of 1d linear interpolator ! +! ! +! - offset version - ! +! ! +!*********************************************************************** +(this,W,V_out,km_in,ibm,jbm) +!----------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: km_in,ibm,jbm +real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W +real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out +real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX +real(r_kind), dimension(km_in):: wk +real(r_kind), dimension(km_in):: vxk +integer(i_kind):: i,j,n,m,l,k +real(r_kind):: c0,c1 +!----------------------------------------------------------------------- + V_out(:,:,:)=0. + VX(:,:,:)=0. + +!$OMP PARALLEL PRIVATE(j,m,n,i,c0,c1,wk,vxk) + + do m=1,this%mm + j = this%jrefL(m) + c0 = this%Ly0(m) + c1 = this%Ly1(m) + do n=1,this%nm + wk(:)=W(:,n,m) + VX(:,n,j ) = VX(:,n,j )+wk(:)*c0 + VX(:,n,j+1) = VX(:,n,j+1)+wk(:)*c1 + enddo + enddo + + do n=1,this%nm + i = this%irefL(n) + c0 = this%Lx0(n) + c1 = this%Lx1(n) + do j=1-jbm,this%jm+jbm + vxk(:)=VX(:,n,j) + V_out(:,i ,j) = V_out(:,i ,j)+vxk(:)*c0 + V_out(:,i+1,j) = V_out(:,i+1,j)+vxk(:)*c1 + enddo + enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine lin_adjoint_offset + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_adjoint_spec2 & +!*********************************************************************** +! ! +! Adjoint of linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nm = 2*km-1 ) ! +! ! +!*********************************************************************** +(this,en,nm_in,km_in,imin,imax,jmin,jmax,W,F) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: en,nm_in,km_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(in):: W +real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(out):: F +integer(i_kind):: k,n,e,enm,ekm +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(n,k) + F = 0. + +do e=0,en-1 + enm = e*nm_in + ekm = e*km_in + k=1 + do n=2,nm_in-1,2 + F(ekm+k ,:,:) = F(ekm+k ,:,:)+0.5*W(enm+n,:,:) + F(ekm+k+1,:,:) = F(ekm+k+1,:,:)+0.5*W(enm+n,:,:) + k=k+1 + enddo + + k=1 + do n=1,nm_in,2 + F(ekm+k,:,:) = F(ekm+k,:,:) + W(enm+n,:,:) + k=k+1 + enddo +enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine l_vertical_adjoint_spec2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine l_vertical_direct_spec2 & +!*********************************************************************** +! ! +! ! +! Direct linear interpolations in vertical ! +! from reslution nm to resolution km ! +! ! +! ( nmax = 2*kmax-1 ) ! +! ! +!*********************************************************************** +(this,en,km_in,nm_in,imin,imax,jmin,jmax,F,W) +implicit none +!----------------------------------------------------------------------- +class(mg_intstate_type),target::this +integer(i_kind), intent(in):: en,km_in,nm_in,imin,imax,jmin,jmax +real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(in):: F +real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(out):: W +integer(i_kind):: k,n,e,enm,ekm +!----------------------------------------------------------------------- +!$OMP PARALLEL PRIVATE(n,k) + +do e=0,en-1 + enm = e*nm_in + ekm = e*km_in + k=1 + do n=1,nm_in,2 + W(enm+n,:,:) =F (ekm+k,:,:) + k=k+1 + enddo + k=1 + do n=2,nm_in-1,2 + W(enm+n,:,:) = 0.5*(F(ekm+k,:,:)+F(ekm+k+1,:,:)) + k=k+1 + enddo +enddo + +!$OMP END PARALLEL +!----------------------------------------------------------------------- +endsubroutine l_vertical_direct_spec2 + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_interpolate diff --git a/src/mgbf/mg_intstate.f90 b/src/mgbf/mg_intstate.f90 new file mode 100644 index 0000000000..28a827c43e --- /dev/null +++ b/src/mgbf/mg_intstate.f90 @@ -0,0 +1,1385 @@ +module mg_intstate +!$$$ submodule documentation block +! . . . . +! module: mg_intstate +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Contains declarations and allocations of internal +! state variables use for filtering (offset version) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! allocate_mg_intstate - +! def_mg_weights - +! init_mg_line - +! deallocate_mg_intstate - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use kinds, only: r_kind,i_kind +use jp_pkind2, only: fpi +use jp_pbfil3, only: inimomtab,t22_to_3,tritform,t33_to_6,hextform +use mg_parameter,only: mg_parameter_type +implicit none +type,extends( mg_parameter_type):: mg_intstate_type +real(r_kind), allocatable,dimension(:,:,:):: V +! +! Composite control variable on first generation of filter grid +! +real(r_kind), allocatable,dimension(:,:,:):: VALL +! +! Composite control variable on high generations of filter grid +! +real(r_kind), allocatable,dimension(:,:,:):: HALL + +real(r_kind), allocatable,dimension(:,:,:):: a_diff_f +real(r_kind), allocatable,dimension(:,:,:):: a_diff_h +real(r_kind), allocatable,dimension(:,:,:):: b_diff_f +real(r_kind), allocatable,dimension(:,:,:):: b_diff_h + +! +! Localization weights +! +real(r_kind), allocatable,dimension(:,:,:):: w1_loc +real(r_kind), allocatable,dimension(:,:,:):: w2_loc +real(r_kind), allocatable,dimension(:,:,:):: w3_loc +real(r_kind), allocatable,dimension(:,:,:):: w4_loc + +real(r_kind), allocatable,dimension(:,:):: p_eps +real(r_kind), allocatable,dimension(:,:):: p_del +real(r_kind), allocatable,dimension(:,:):: p_sig +real(r_kind), allocatable,dimension(:,:):: p_rho + +real(r_kind), allocatable,dimension(:,:,:):: paspx +real(r_kind), allocatable,dimension(:,:,:):: paspy +real(r_kind), allocatable,dimension(:,:,:):: pasp1 +real(r_kind), allocatable,dimension(:,:,:,:):: pasp2 +real(r_kind), allocatable,dimension(:,:,:,:,:):: pasp3 + +real(r_kind), allocatable,dimension(:,:,:):: vpasp2 +real(r_kind), allocatable,dimension(:,:,:):: hss2 +real(r_kind), allocatable,dimension(:,:,:,:):: vpasp3 +real(r_kind), allocatable,dimension(:,:,:,:):: hss3 + +real(r_kind), allocatable,dimension(:):: ssx +real(r_kind), allocatable,dimension(:):: ssy +real(r_kind), allocatable,dimension(:):: ss1 +real(r_kind), allocatable,dimension(:,:):: ss2 +real(r_kind), allocatable,dimension(:,:,:):: ss3 + +integer(fpi), allocatable,dimension(:,:,:):: dixs +integer(fpi), allocatable,dimension(:,:,:):: diys +integer(fpi), allocatable,dimension(:,:,:):: dizs + +integer(fpi), allocatable,dimension(:,:,:,:):: dixs3 +integer(fpi), allocatable,dimension(:,:,:,:):: diys3 +integer(fpi), allocatable,dimension(:,:,:,:):: dizs3 + +integer(fpi), allocatable,dimension(:,:,:,:):: qcols + +integer(i_kind),allocatable,dimension(:):: iref,jref +integer(i_kind),allocatable,dimension(:):: irefq,jrefq +integer(i_kind),allocatable,dimension(:):: irefL,jrefL + +integer(i_kind),allocatable,dimension(:):: Lref,Lref_h +real(r_kind),allocatable,dimension(:):: cvf1,cvf2,cvf3,cvf4 +real(r_kind),allocatable,dimension(:):: cvh1,cvh2,cvh3,cvh4 + +real(r_kind),allocatable,dimension(:):: cx0,cx1,cx2,cx3 +real(r_kind),allocatable,dimension(:):: cy0,cy1,cy2,cy3 + +real(r_kind),allocatable,dimension(:):: qx0,qx1,qx2 +real(r_kind),allocatable,dimension(:):: qy0,qy1,qy2 + +real(r_kind),allocatable,dimension(:):: Lx0,Lx1 +real(r_kind),allocatable,dimension(:):: Ly0,Ly1 + +real(r_kind),allocatable,dimension(:):: p_coef,q_coef +real(r_kind),allocatable,dimension(:):: a_coef,b_coef + +real(r_kind),allocatable,dimension(:,:):: cf00,cf01,cf02,cf03 & + ,cf10,cf11,cf12,cf13 & + ,cf20,cf21,cf22,cf23 & + ,cf30,cf31,cf32,cf33 +contains + procedure :: allocate_mg_intstate,deallocate_mg_intstate + procedure :: def_mg_weights,init_mg_line +!from mg_interpolate.f90 + procedure :: def_offset_coef + procedure :: lsqr_mg_coef,lwq_vertical_coef + procedure :: lwq_vertical_direct,lwq_vertical_adjoint + procedure :: lwq_vertical_direct_spec,lwq_vertical_adjoint_spec + procedure :: l_vertical_direct_spec,l_vertical_adjoint_spec + procedure :: l_vertical_direct_spec2,l_vertical_adjoint_spec2 + procedure :: lsqr_direct_offset,lsqr_adjoint_offset + procedure :: quad_direct_offset,quad_adjoint_offset + procedure :: lin_direct_offset,lin_adjoint_offset +!from mg_bocos.f90 + generic :: boco_2d => boco_2d_g1,boco_2d_gh + procedure :: boco_2d_g1,boco_2d_gh + generic :: boco_3d => boco_3d_g1,boco_3d_gh + procedure :: boco_3d_g1,boco_3d_gh + generic :: bocoT_2d => bocoT_2d_g1,bocoT_2d_gh + procedure :: bocoT_2d_g1,bocoT_2d_gh + generic :: bocoTx => bocoTx_2d_g1,bocoTx_2d_gh + procedure :: bocoTx_2d_g1,bocoTx_2d_gh + generic :: bocoTy => bocoTy_2d_g1,bocoTy_2d_gh + procedure :: bocoTy_2d_g1,bocoTy_2d_gh + generic :: bocoT_3d => bocoT_3d_g1,bocoT_3d_gh + procedure :: bocoT_3d_g1,bocoT_3d_gh + generic :: bocox => bocox_2d_g1,bocox_2d_gh + procedure :: bocox_2d_g1,bocox_2d_gh + generic :: bocoy => bocoy_2d_g1,bocoy_2d_gh + procedure :: bocoy_2d_g1,bocoy_2d_gh + generic :: upsend_all => upsend_all_g1,upsend_all_gh + procedure :: upsend_all_g1,upsend_all_gh + generic :: downsend_all => downsend_all_g2,downsend_all_gh + procedure :: downsend_all_g2,downsend_all_gh + procedure :: boco_2d_loc + procedure :: bocoT_2d_loc + procedure :: upsend_loc_g12 + procedure :: upsend_loc_g23 + procedure :: upsend_loc_g34 + procedure :: downsend_loc_g43 + procedure :: downsend_loc_g32 + procedure :: downsend_loc_g21 +!from mg_generation.f90 + procedure:: upsending_all,downsending_all,weighting_all + procedure:: upsending,downsending + procedure:: upsending_highest,downsending_highest + procedure:: upsending2,downsending2 + procedure:: upsending_ens,downsending_ens + procedure:: upsending2_ens,downsending2_ens + procedure:: upsending_ens_nearest,downsending_ens_nearest + generic :: upsending_loc => upsending_loc_g3,upsending_loc_g4 + procedure:: upsending_loc_g3,upsending_loc_g4 + generic :: downsending_loc => downsending_loc_g3,downsending_loc_g4 + procedure:: downsending_loc_g3,downsending_loc_g4 + procedure:: weighting_helm,weighting,weighting_highest,weighting_ens + generic :: weighting_loc => weighting_loc_g3,weighting_loc_g4 + procedure:: weighting_loc_g3,weighting_loc_g4 + procedure:: adjoint,direct1 + procedure:: adjoint2,direct2 + procedure:: adjoint_nearest,direct_nearest + procedure:: adjoint_highest,direct_highest +!from mg_filtering.f90 + procedure :: filtering_procedure + procedure :: filtering_rad3,filtering_lin3 + procedure :: filtering_rad2_bkg,filtering_lin2_bkg,filtering_fast_bkg + procedure :: filtering_rad2_ens,filtering_lin2_ens,filtering_fast_ens + procedure :: filtering_rad_highest + procedure :: sup_vrbeta1T,sup_vrbeta1,sup_vrbeta3T,sup_vrbeta3 + procedure :: sup_vrbeta1_ens,sup_vrbeta1T_ens + procedure :: sup_vrbeta1_bkg,sup_vrbeta1T_bkg +!from mg_transfer.f90 + procedure :: anal_to_filt_all,filt_to_anal_all + procedure :: anal_to_filt_all2,filt_to_anal_all2 + procedure :: composite_to_stack,stack_to_composite + procedure :: C2S_ens,S2C_ens + procedure :: anal_to_filt,filt_to_anal +!from mg_entrymod.f90 + procedure :: mg_initialize + procedure :: mg_finalize +end type mg_intstate_type +interface +!from mg_interpolate.f90 + module subroutine def_offset_coef(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine lsqr_mg_coef(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine lwq_vertical_coef & + (this,nm_in,im_in,c1,c2,c3,c4,iref_out) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: nm_in,im_in + real(r_kind), dimension(1:nm_in), intent(out):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(out):: iref_out + end subroutine + module subroutine lwq_vertical_direct & + (this,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,f,w) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(in):: f + real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(out):: w + end subroutine + module subroutine lwq_vertical_adjoint & + (this,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,w,f) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:nm_in,imin:imax,jmin:jmax), intent(in):: w + real(r_kind), dimension(1:km_in,imin:imax,jmin:jmax), intent(out):: f + end subroutine + module subroutine lwq_vertical_direct_spec & + (this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,F,W) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W + end subroutine + module subroutine lwq_vertical_adjoint_spec & + (this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,c1,c2,c3,c4,kref,W,F) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in), intent(in):: c1,c2,c3,c4 + integer(i_kind), dimension(1:nm_in), intent(in):: kref + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F + end subroutine + module subroutine l_vertical_direct_spec & + (this,km3_in,km_in,nm_in,imin,imax,jmin,jmax,F,W) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(in):: F + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(out):: W + end subroutine + module subroutine l_vertical_adjoint_spec & + (this,km3_in,nm_in,km_in,imin,imax,jmin,jmax,W,F) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:nm_in), intent(in):: W + real(r_kind), dimension(1:km3_in,imin:imax,jmin:jmax,1:km_in), intent(out):: F + end subroutine + module subroutine l_vertical_direct_spec2 & + (this,en,km_in,nm_in,imin,imax,jmin,jmax,f,w) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: en,km_in,nm_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(in):: F + real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(out):: W + end subroutine + module subroutine l_vertical_adjoint_spec2 & + (this,en,nm_in,km_in,imin,imax,jmin,jmax,w,f) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: en,nm_in,km_in,imin,imax,jmin,jmax + real(r_kind), dimension(1:nm_in*en,imin:imax,jmin:jmax), intent(in):: W + real(r_kind), dimension(1:km_in*en,imin:imax,jmin:jmax), intent(out):: F + end subroutine + module subroutine lsqr_direct_offset & + (this,V_in,W,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine lsqr_adjoint_offset & + (this,W,V_out,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine quad_direct_offset & + (this,V_in,W,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine quad_adjoint_offset & + (this,W,V_out,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out + real(r_kind), dimension(km_in,1:this%nm,1-jbm:this%jm+jbm):: VX + end subroutine + module subroutine lin_direct_offset & + (this,V_in,W,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(in):: V_in + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(out):: W + end subroutine + module subroutine lin_adjoint_offset & + (this,W,V_out,km_in,ibm,jbm) + implicit none + class(mg_intstate_type),target::this + integer(i_kind):: km_in,ibm,jbm + real(r_kind), dimension(km_in,1:this%nm,1:this%mm),intent(in):: W + real(r_kind), dimension(km_in,1-ibm:this%im+ibm,1-jbm:this%jm+jbm), intent(out):: V_out + end subroutine +!from mg_bocos.f90 + module subroutine boco_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine boco_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine boco_3d_g1 & + (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz + real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine boco_3d_gh & + (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max + real(r_kind),dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoT_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoTx_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoTx_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoTy_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoTy_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_3d_g1 & + (this,W,km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km3_in,im_in,jm_in,Lm_in,nbx,nby,nbz + real(r_kind), dimension(km3_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_3d_gh & + (this,W,km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,Lm_in,nbx,nby,nbz,mygen_min,mygen_max + real(r_kind), dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby,1-nbz:Lm_in+nbz),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocox_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocox_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoy_2d_g1 & + (this,W,km_in,im_in,jm_in,nbx,nby) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + end subroutine + module subroutine bocoy_2d_gh & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,mygen_min,mygen_max) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,mygen_min,mygen_max + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine upsend_all_g1 & + (this,Harray,Warray,km_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray + real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray + end subroutine + module subroutine upsend_all_gh & + (this,Harray,Warray,km_in,mygen_dn,mygen_up) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(in):: Harray + real(r_kind), dimension(km_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Warray + integer(i_kind),intent(in):: mygen_dn,mygen_up + end subroutine + module subroutine downsend_all_gh & + (this,Warray,Harray,km_in,mygen_up,mygen_dn) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray + integer, intent(in):: mygen_up,mygen_dn + end subroutine + module subroutine downsend_all_g2 & + (this,Warray,Harray,km_in) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm),intent(in):: Warray + real(r_kind), dimension(km_in,1:this%imL,1:this%jmL),intent(out):: Harray + end subroutine + module subroutine boco_2d_loc & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine bocoT_2d_loc & + (this,W,km_in,im_in,jm_in,nbx,nby,Fimax_in,Fjmax_in,g) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_in,im_in,jm_in,nbx,nby,g + real(r_kind),dimension(km_in,1-nbx:im_in+nbx,1-nby:jm_in+nby),intent(inout):: W + integer(i_kind), dimension(this%gm), intent(in):: Fimax_in,Fjmax_in + end subroutine + module subroutine upsend_loc_g12 & + (this,V_in,H,km_4_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_4_in,flag + real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(in):: V_in + real(r_kind), dimension(km_4_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine upsend_loc_g23 & + (this,V_in,H,km_16_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_16_in,flag + real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(in):: V_in + real(r_kind), dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine upsend_loc_g34 & + (this,V_in,H,km_64_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_64_in,flag + real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(in):: V_in + real(r_kind), dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsend_loc_g43 & + (this,W,Z,km_64_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_64_in,flag + real(r_kind), dimension(km_64_in,1:this%im,1:this%jm),intent(in):: W + real(r_kind), dimension(km_64_in,1:this%imL,1:this%jmL),intent(out):: Z + end subroutine + module subroutine downsend_loc_g32 & + (this,Z,H,km_16_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_16_in,flag + real(r_kind), dimension(km_16_in,1:this%im,1:this%jm),intent(in):: Z + real(r_kind), dimension(km_16_in,1:this%imL,1:this%jmL),intent(out):: H + end subroutine + module subroutine downsend_loc_g21 & + (this,H,V_out,km_4_in,flag) + implicit none + class(mg_intstate_type),target::this + integer(i_kind), intent(in):: km_4_in,flag + real(r_kind), dimension(km_4_in,1:this%im,1:this%jm),intent(in):: H + real(r_kind), dimension(km_4_in,1:this%imL,1:this%jmL),intent(out):: V_out + end subroutine +!from mg_generations.f90 + module subroutine upsending_all & + (this,V,H,lquart) + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + logical, intent(in):: lquart + end subroutine + module subroutine downsending_all & + (this,H,V,lquart) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + logical, intent(in):: lquart + end subroutine + module subroutine weighting_all & + (this,V,H,lhelm) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + logical, intent(in):: lhelm + end subroutine + module subroutine upsending & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: V_INT + real(r_kind),dimension(this%km,-1:this%imL+2,-1:this%jmL+2):: H_INT + end subroutine + module subroutine downsending & + (this,H,V) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending2 & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending2 & + (this,H,V) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_highest & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending_highest & + (this,H,V) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_ens & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending_ens & + (this,H,V,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending2_ens & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending2_ens & + (this,H,V,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_ens_nearest & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + end subroutine + module subroutine downsending_ens_nearest & + (this,H,V,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind), intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine upsending_loc_g3 & + (this,V,H,Z,km_in,km_4_in,km_16_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z + end subroutine + module subroutine upsending_loc_g4 & + (this,V,H,Z,W,km_in,km_4_in,km_16_in,km_64_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(in):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: H + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: Z + real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(out):: W + end subroutine + module subroutine downsending_loc_g3 & + (this,Z,H,V,km_in,km_4_in,km_16_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine downsending_loc_g4 & + (this,W,Z,H,V,km_in,km_4_in,km_16_in,km_64_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in + real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: W + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: Z + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + end subroutine + module subroutine weighting_helm & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting & + (this,V,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting_highest & + (this,H) + implicit none + class (mg_intstate_type),target:: this + real(r_kind),dimension(this%km,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting_ens & + (this,V,H,kmx) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: kmx + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(kmx,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H + end subroutine + module subroutine weighting_loc_g3 & + (this,V,H04,H16,km_in,km_4_in,km_16_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 + end subroutine + module subroutine weighting_loc_g4 & + (this,V,H04,H16,H64,km_in,km_4_in,km_16_in,km_64_in) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: km_in,km_4_in,km_16_in,km_64_in + real(r_kind),dimension(km_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: V + real(r_kind),dimension(km_4_in ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H04 + real(r_kind),dimension(km_16_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H16 + real(r_kind),dimension(km_64_in,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy),intent(inout):: H64 + end subroutine + module subroutine adjoint & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W + end subroutine + module subroutine direct1 & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F + end subroutine + module subroutine adjoint2 & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F + real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(out):: W + end subroutine + module subroutine direct2 & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,0:this%imL+1,0:this%jmL+1), intent(in):: W + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F + end subroutine + module subroutine adjoint_nearest & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(in):: F + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(out):: W + end subroutine + module subroutine direct_nearest & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,-1:this%imL+2,-1:this%jmL+2), intent(in):: W + real(r_kind), dimension(km_in,1:this%im,1:this%jm), intent(out):: F + end subroutine + module subroutine adjoint_highest & + (this,F,W,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(in):: F + real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(out):: W + end subroutine + module subroutine direct_highest & + (this,W,F,km_in,g) + implicit none + class (mg_intstate_type),target:: this + integer(i_kind),intent(in):: g + integer(i_kind),intent(in):: km_in + real(r_kind), dimension(km_in,-1:this%im0(g+1)+2,-1:this%jm0(g+1)+2), intent(in):: W + real(r_kind), dimension(km_in,1:this%im0(g),1:this%jm0(g)), intent(out):: F + end subroutine +!from mg_filtering + module subroutine filtering_procedure(this,mg_filt,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_rad3(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_lin3(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_rad2_bkg(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_lin2_bkg(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_fast_bkg(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine filtering_rad2_ens(this,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_lin2_ens(this,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_fast_ens(this,mg_filt_flag) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: mg_filt_flag + end subroutine + module subroutine filtering_rad_highest(this) + class(mg_intstate_type),target::this + end subroutine + module subroutine sup_vrbeta1 & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1T & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta3 & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss, V) + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp + real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta3T & + (this,kmax,hx,hy,hz,im,jm,lm, pasp,ss,V) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: kmax,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:kmax,1-hx:im+hx,1-hy:jm+hy,1:lm),intent(inout):: V + real(r_kind),dimension(3,3,1:im,1:jm,1:lm), intent(in):: pasp + real(r_kind),dimension(1:im,1:jm,1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1_ens & + (this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1T_ens & + (this,km_en,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km_en,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km_en*lm,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1_bkg & + (this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine + module subroutine sup_vrbeta1T_bkg & + (this,km,km3,hx,hy,hz,im,jm,lm,pasp,ss,VALL) + implicit none + class(mg_intstate_type),target::this + integer(i_kind),intent(in):: km,km3,hx,hy,hz,im,jm,lm + real(r_kind),dimension(1:km,1-hx:im+hx,1-hy:jm+hy),intent(inout):: VALL + real(r_kind),dimension(1,1,1:lm), intent(in):: pasp + real(r_kind),dimension(1:lm), intent(in):: ss + end subroutine +!from mg_transfer.f90 + module subroutine anal_to_filt_all(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal_all(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine anal_to_filt_all2(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal_all2(this,WORKA) + class(mg_intstate_type),target::this + real (r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) + end subroutine + module subroutine stack_to_composite(this,ARR_ALL,A2D,A3D) + class(mg_intstate_type),target::this + real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: ARR_ALL + real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D + real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy) ,intent(out):: A2D + end subroutine + module subroutine composite_to_stack(this,A2D,A3D,ARR_ALL) + class(mg_intstate_type),target::this + real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: A2D + real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D + real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(out):: ARR_ALL + end subroutine + module subroutine S2C_ens(this,ARR_ALL,A3D,imn,imx,jmn,jmx,lmx,kmx,kmx_all) + class(mg_intstate_type),target::this + integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all + real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(in):: ARR_ALL + real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(out):: A3D + end subroutine + module subroutine C2S_ens(this,A3D,ARR_ALL,imn,imx,jmn,jmx,lmx,kmx,kmx_all) + class(mg_intstate_type),target::this + integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all + real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(in):: A3D + real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(out):: ARR_ALL + end subroutine + module subroutine anal_to_filt(this,WORK) + class(mg_intstate_type),target::this + real (r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) + end subroutine + module subroutine filt_to_anal(this,WORK) + class(mg_intstate_type),target::this + real (r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) + end subroutine +!from mg_entrymod.f90 + module subroutine mg_initialize(this,inputfilename,obj_parameter) + class (mg_intstate_type):: this + character*(*),optional,intent(in) :: inputfilename + class(mg_parameter_type),optional,intent(in)::obj_parameter + end subroutine + module subroutine mg_finalize(this) + implicit none + class (mg_intstate_type)::this + end subroutine +end interface + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine allocate_mg_intstate(this) +!*********************************************************************** +! ! +! Allocate internal state variables ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this + +if(this%l_loc) then + allocate(this%w1_loc(this%km_all ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w1_loc=0. + allocate(this%w2_loc(this%km_all/4 ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w2_loc=0. + allocate(this%w3_loc(this%km_all/16,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w3_loc=0. + allocate(this%w4_loc(this%km_all/64,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%w4_loc=0. +endif + +allocate(this%V(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm)) ; this%V=0. +allocate(this%VALL(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%VALL=0. +allocate(this%HALL(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%HALL=0. + +allocate(this%a_diff_f(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%a_diff_f=0. +allocate(this%a_diff_h(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%a_diff_h=0. +allocate(this%b_diff_f(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%b_diff_f=0. +allocate(this%b_diff_h(this%km_all,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%b_diff_h=0. + +allocate(this%p_eps(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_eps=0. +allocate(this%p_del(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_del=0. +allocate(this%p_sig(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_sig=0. +allocate(this%p_rho(1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy)) ; this%p_rho=0. + +allocate(this%paspx(1,1,1:this%im)) ; this%paspx=0. +allocate(this%paspy(1,1,1:this%jm)) ; this%paspy=0. + +allocate(this%pasp1(1,1,1:this%lm)) ; this%pasp1=0. +allocate(this%pasp2(2,2,1:this%im,1:this%jm)) ; this%pasp2=0. +allocate(this%pasp3(3,3,1:this%im,1:this%jm,1:this%lm)) ; this%pasp3=0. + +allocate(this%vpasp2(0:2,1:this%im,1:this%jm)) ; this%vpasp2=0. +allocate(this%hss2(1:this%im,1:this%jm,1:3)) ; this%hss2=0. + +allocate(this%vpasp3(1:6,1:this%im,1:this%jm,1:this%lm)) ; this%vpasp3=0. +allocate(this%hss3(1:this%im,1:this%jm,1:this%lm,1:6)) ; this%hss3=0. + +allocate(this%ssx(1:this%im)) ; this%ssx=0. +allocate(this%ssy(1:this%jm)) ; this%ssy=0. +allocate(this%ss1(1:this%lm)) ; this%ss1=0. +allocate(this%ss2(1:this%im,1:this%jm)) ; this%ss2=0. +allocate(this%ss3(1:this%im,1:this%jm,1:this%lm)) ; this%ss3=0. + +allocate(this%dixs(1:this%im,1:this%jm,3)) ; this%dixs=0 +allocate(this%diys(1:this%im,1:this%jm,3)) ; this%diys=0 + +allocate(this%dixs3(1:this%im,1:this%jm,1:this%lm,6)) ; this%dixs3=0 +allocate(this%diys3(1:this%im,1:this%jm,1:this%lm,6)) ; this%diys3=0 +allocate(this%dizs3(1:this%im,1:this%jm,1:this%lm,6)) ; this%dizs3=0 + +allocate(this%qcols(0:7,1:this%im,1:this%jm,1:this%lm)) ; this%qcols=0 + +! +! for re-decomposition +! + +allocate(this%iref(1:this%nm)) ; this%iref=0 +allocate(this%jref(1:this%mm)) ; this%jref=0 + +allocate(this%irefq(1:this%nm)) ; this%irefq=0 +allocate(this%jrefq(1:this%mm)) ; this%jrefq=0 + +allocate(this%irefL(1:this%nm)) ; this%irefL=0 +allocate(this%jrefL(1:this%mm)) ; this%jrefL=0 + +allocate(this%cx0(1:this%nm)) ; this%cx0=0. +allocate(this%cx1(1:this%nm)) ; this%cx1=0. +allocate(this%cx2(1:this%nm)) ; this%cx2=0. +allocate(this%cx3(1:this%nm)) ; this%cx3=0. + +allocate(this%cy0(1:this%mm)) ; this%cy0=0. +allocate(this%cy1(1:this%mm)) ; this%cy1=0. +allocate(this%cy2(1:this%mm)) ; this%cy2=0. +allocate(this%cy3(1:this%mm)) ; this%cy3=0. + +allocate(this%qx0(1:this%nm)) ; this%qx0=0. +allocate(this%qx1(1:this%nm)) ; this%qx1=0. +allocate(this%qx2(1:this%nm)) ; this%qx2=0. + +allocate(this%qy0(1:this%mm)) ; this%qy0=0. +allocate(this%qy1(1:this%mm)) ; this%qy1=0. +allocate(this%qy2(1:this%mm)) ; this%qy2=0. + +allocate(this%Lx0(1:this%nm)) ; this%Lx0=0. +allocate(this%Lx1(1:this%nm)) ; this%Lx1=0. + +allocate(this%Ly0(1:this%mm)) ; this%Ly0=0. +allocate(this%Ly1(1:this%mm)) ; this%Ly1=0. + +allocate(this%p_coef(4)) ; this%p_coef=0. +allocate(this%q_coef(4)) ; this%q_coef=0. + +allocate(this%a_coef(3)) ; this%a_coef=0. +allocate(this%b_coef(3)) ; this%b_coef=0. + +allocate(this%cf00(1:this%nm,1:this%mm)) ; this%cf00=0. +allocate(this%cf01(1:this%nm,1:this%mm)) ; this%cf01=0. +allocate(this%cf02(1:this%nm,1:this%mm)) ; this%cf02=0. +allocate(this%cf03(1:this%nm,1:this%mm)) ; this%cf03=0. +allocate(this%cf10(1:this%nm,1:this%mm)) ; this%cf10=0. +allocate(this%cf11(1:this%nm,1:this%mm)) ; this%cf11=0. +allocate(this%cf12(1:this%nm,1:this%mm)) ; this%cf12=0. +allocate(this%cf13(1:this%nm,1:this%mm)) ; this%cf13=0. +allocate(this%cf20(1:this%nm,1:this%mm)) ; this%cf20=0. +allocate(this%cf21(1:this%nm,1:this%mm)) ; this%cf21=0. +allocate(this%cf22(1:this%nm,1:this%mm)) ; this%cf22=0. +allocate(this%cf23(1:this%nm,1:this%mm)) ; this%cf23=0. +allocate(this%cf30(1:this%nm,1:this%mm)) ; this%cf30=0. +allocate(this%cf31(1:this%nm,1:this%mm)) ; this%cf31=0. +allocate(this%cf32(1:this%nm,1:this%mm)) ; this%cf32=0. +allocate(this%cf33(1:this%nm,1:this%mm)) ; this%cf33=0. + +allocate(this%Lref(1:this%lm_a)) ; this%Lref=0 +allocate(this%Lref_h(1:this%lm)) ; this%Lref_h=0 + +allocate(this%cvf1(1:this%lm_a)) ; this%cvf1=0. +allocate(this%cvf2(1:this%lm_a)) ; this%cvf2=0. +allocate(this%cvf3(1:this%lm_a)) ; this%cvf3=0. +allocate(this%cvf4(1:this%lm_a)) ; this%cvf4=0. + +allocate(this%cvh1(1:this%lm)) ; this%cvh1=0. +allocate(this%cvh2(1:this%lm)) ; this%cvh2=0. +allocate(this%cvh3(1:this%lm)) ; this%cvh3=0. +allocate(this%cvh4(1:this%lm)) ; this%cvh4=0. + +!----------------------------------------------------------------------- +endsubroutine allocate_mg_intstate + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine def_mg_weights(this) +!*********************************************************************** +! ! +! Define weights and scales ! +! ! +implicit none +class (mg_intstate_type),target::this +!*********************************************************************** +integer(i_kind):: i,j,L +real(r_kind):: gen_fac +!----------------------------------------------------------------------- + +this%p_eps(:,:)=0.0 +this%p_del(:,:)=0.0 +this%p_sig(:,:)=0.0 +this%p_rho(:,:)=0.0 + +!-------------------------------------------------------- +! +! For localization (for now) +! +if(this%l_loc) then + this%w1_loc(:,:,:)=this%mg_weig1 + this%w2_loc(:,:,:)=this%mg_weig2 + this%w3_loc(:,:,:)=this%mg_weig3 + this%w4_loc(:,:,:)=this%mg_weig4 +endif +!-------------------------------------------------------- +gen_fac=1. +this%a_diff_f(:,:,:)=this%mg_weig1 +this%a_diff_h(:,:,:)=this%mg_weig1 + +this%b_diff_f(:,:,:)=0. +this%b_diff_h(:,:,:)=0. + +select case(this%my_hgen) +case(2) + this%a_diff_h(:,:,:)=this%mg_weig2 +case(3) + this%a_diff_h(:,:,:)=this%mg_weig3 +case default + this%a_diff_h(:,:,:)=this%mg_weig4 +end select + +do L=1,this%lm + this%pasp1(1,1,L)=this%pasp01 +enddo + +do i=1,this%im + this%paspx(1,1,i)=this%pasp02 +enddo +do j=1,this%jm + this%paspy(1,1,j)=this%pasp02 +enddo + +do j=1,this%jm +do i=1,this%im + this%pasp2(1,1,i,j)=this%pasp02*(1.+this%p_del(i,j)) + this%pasp2(2,2,i,j)=this%pasp02*(1.-this%p_del(i,j)) + this%pasp2(1,2,i,j)=this%pasp02*this%p_eps(i,j) + this%pasp2(2,1,i,j)=this%pasp02*this%p_eps(i,j) +end do +end do + +do L=1,this%lm + do j=1,this%jm + do i=1,this%im + this%pasp3(1,1,i,j,l)=this%pasp03*(1+this%p_del(i,j)) + this%pasp3(2,2,i,j,l)=this%pasp03 + this%pasp3(3,3,i,j,l)=this%pasp03*(1-this%p_del(i,j)) + this%pasp3(1,2,i,j,l)=this%pasp03*this%p_eps(i,j) + this%pasp3(2,1,i,j,l)=this%pasp03*this%p_eps(i,j) + this%pasp3(2,3,i,j,l)=this%pasp03*this%p_sig(i,j) + this%pasp3(3,2,i,j,l)=this%pasp03*this%p_sig(i,j) + this%pasp3(1,3,i,j,l)=this%pasp03*this%p_rho(i,j) + this%pasp3(3,1,i,j,l)=this%pasp03*this%p_rho(i,j) + end do + end do +end do + + +if(.not.this%mgbf_line) then + if(this%nxm*this%nym>1) then + if(this%l_loc) then + if(this%l_vertical_filter) then + call this%cholaspect(1,this%lm,this%pasp1) + call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1) + do L=1,this%lm + this%VALL(L,2,1)=1. + call this%sup_vrbeta1T_ens(1,0,0,this%hz,1,1,this%lm,this%pasp1,this%ss1,this%VALL(1:this%lm,2,1)) + call this%sup_vrbeta1_ens(1,0,0,this%hz,1,1,this%lm,this%pasp1,this%ss1,this%VALL(1:this%lm,2,1)) + this%VALL(L,1,1)=sqrt(this%VALL(L,2,1)) + this%VALL(1:this%lm,2,1)=0. + enddo + this%ss1(1:this%lm)=this%ss1(1:this%lm)/this%VALL(1:this%lm,1,1) + this%VALL(1:this%lm,1,1)=0. + endif + call this%cholaspect(1,this%im,1,this%jm,this%pasp2) + call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2) + this%VALL(1,this%im/2,this%jm/2)=1. + call this%rbetaT(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2,this%VALL(1,:,:)) + call this%rbeta(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2,this%VALL(1,:,:)) + this%ss2=this%ss2/sqrt(this%VALL(1,this%im/2,this%jm/2)) + this%VALL(1,:,:)=0. + call this%cholaspect(1,this%im,this%paspx) + call this%getlinesum(this%hx,1,this%im,this%paspx,this%ssx) + this%VALL(1,this%im/2,1)=1. + call this%rbetaT(this%hx,1,this%im,this%paspx,this%ssx,this%VALL(1,:,1)) + call this%rbeta(this%hx,1,this%im,this%paspx(1,1,:),this%ssx,this%VALL(1,:,1)) + this%ssx=this%ssx/sqrt(this%VALL(1,this%im/2,1)) + this%VALL(1,:,1)=0. + call this%cholaspect(1,this%jm,this%paspy) + call this%getlinesum(this%hy,1,this%jm,this%paspy,this%ssy) + this%VALL(1,1,this%jm/2)=1. + call this%rbetaT(this%hy,1,this%jm,this%paspy,this%ssy,this%VALL(1,1,:)) + call this%rbeta(this%hy,1,this%jm,this%paspy(1,1,:),this%ssy,this%VALL(1,1,:)) + this%ssy=this%ssy/sqrt(this%VALL(1,1,this%jm/2)) + this%VALL(1,1,:)=0. + else + call this%cholaspect(1,this%lm,this%pasp1) + call this%cholaspect(1,this%im,1,this%jm,this%pasp2) + call this%cholaspect(1,this%im,1,this%jm,1,this%lm,this%pasp3) + call this%getlinesum(this%hx,1,this%im,this%paspx,this%ssx) + call this%getlinesum(this%hy,1,this%jm,this%paspy,this%ssy) + call this%getlinesum(this%hz,1,this%lm,this%pasp1,this%ss1) + call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%pasp2,this%ss2) + call this%getlinesum(this%hx,1,this%im,this%hy,1,this%jm,this%hz,1,this%lm,this%pasp3,this%ss3) + end if + else + call this%cholaspect(1,this%imH,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH)) + call this%getlinesum(this%hx,1,this%imH,this%hy,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH)) + this%VALL(1,this%imH/2,this%jmH/2)=1. + call this%rbetaT(this%hx,1,this%imH,this%hy,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH),& + &this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)) + call this%rbeta(this%hx,1,this%imH,this%hy,1,this%jmH,& + &this%pasp2(:,:,1:this%imH,1:this%jmH),this%ss2(1:this%imH,1:this%jmH),& + &this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)) + this%ss2=this%ss2/sqrt(this%VALL(1,this%imH/2,this%jmH/2)) + this%VALL(1,1-this%hx:this%imH+this%hx,1-this%hy:this%jmH+this%hy)=0. + end if +end if +!----------------------------------------------------------------------- +endsubroutine def_mg_weights + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine init_mg_line(this) +implicit none +class(mg_intstate_type),target::this +integer(i_kind):: i,j,L,icol +logical:: ff +!*********************************************************************** +! ! +! Inititate line filters ! +! ! +!*********************************************************************** +!----------------------------------------------------------------------- + +do j=1,this%jm +do i=1,this%im + call t22_to_3(this%pasp2(:,:,i,j),this%vpasp2(:,i,j)) +enddo +enddo + +do l=1,this%lm +do j=1,this%jm +do i=1,this%im + call t33_to_6(this%pasp3(:,:,i,j,l),this%vpasp3(:,i,j,l)) +enddo +enddo +enddo + +call inimomtab(this%p,this%nh,ff) + +call tritform(1,this%im,1,this%jm,this%vpasp2, this%dixs,this%diys, ff) + +do icol=1,3 + this%hss2(:,:,icol)=this%vpasp2(icol-1,:,:) +enddo + +call hextform(1,this%im,1,this%jm,1,this%lm,this%vpasp3,this%qcols,this%dixs3,this%diys3,this%dizs3, ff) + +do icol=1,6 + this%hss3(:,:,:,icol)=this%vpasp3(icol,:,:,:) +enddo + +!----------------------------------------------------------------------- +endsubroutine init_mg_line + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine deallocate_mg_intstate(this) +implicit none +class (mg_intstate_type),target:: this +!*********************************************************************** +! ! +! Deallocate internal state variables ! +! ! +!*********************************************************************** + +deallocate(this%V) + +deallocate(this%HALL,this%VALL) + +deallocate(this%a_diff_f,this%b_diff_f) +deallocate(this%a_diff_h,this%b_diff_h) +deallocate(this%p_eps,this%p_del,this%p_sig,this%p_rho,this%pasp1,this%pasp2,this%pasp3,this%ss1,this%ss2,this%ss3) +deallocate(this%dixs,this%diys) +deallocate(this%dixs3,this%diys3,this%dizs3) +deallocate(this%qcols) + +! +! for re-decomposition +! +deallocate(this%iref,this%jref) +deallocate(this%irefq,this%jrefq) +deallocate(this%irefL,this%jrefL) + +deallocate(this%cf00,this%cf01,this%cf02,this%cf03,this%cf10,this%cf11,this%cf12,this%cf13) +deallocate(this%cf20,this%cf21,this%cf22,this%cf23,this%cf30,this%cf31,this%cf32,this%cf33) + +deallocate(this%Lref,this%Lref_h) + +deallocate(this%cvf1,this%cvf2,this%cvf3,this%cvf4) + +deallocate(this%cvh1,this%cvh2,this%cvh3,this%cvh4) + +deallocate(this%cx0,this%cx1,this%cx2,this%cx3) +deallocate(this%cy0,this%cy1,this%cy2,this%cy3) + +deallocate(this%qx0,this%qx1,this%qx2) +deallocate(this%qy0,this%qy1,this%qy2) + +deallocate(this%Lx0,this%Lx1) +deallocate(this%Ly0,this%Ly1) + +deallocate(this%p_coef,this%q_coef) +deallocate(this%a_coef,this%b_coef) + +if(this%l_loc) then + deallocate(this%w1_loc,this%w2_loc,this%w3_loc,this%w4_loc) +endif + +end subroutine deallocate_mg_intstate + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module mg_intstate diff --git a/src/mgbf/mg_mppstuff.f90 b/src/mgbf/mg_mppstuff.f90 new file mode 100644 index 0000000000..e1d24b180c --- /dev/null +++ b/src/mgbf/mg_mppstuff.f90 @@ -0,0 +1,190 @@ +submodule(mg_parameter) mg_mppstuff +!$$$ submodule documentation block +! . . . . +! module: mg_mppstuff +! prgmmr: rancic org: NCEP/EMC date: 2020 +! +! abstract: Everything related to mpi communication +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_mg_MPI - +! barrierMPI - +! finishMPI - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: i_kind +implicit none + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine init_mg_MPI(this) +!*********************************************************************** +! ! +! Initialize mpi ! +! Create group for filter grid ! +! ! +!*********************************************************************** +use mpi + +implicit none +class (mg_parameter_type),target:: this +integer(i_kind):: g,m +integer(i_kind), dimension(this%npes_filt):: out_ranks +integer(i_kind):: nf +integer(i_kind)::ierr +integer(i_kind):: color +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + +!*** +!*** Initial MPI calls +!*** + call MPI_COMM_RANK(MPI_COMM_WORLD,mype,ierr) + call MPI_COMM_SIZE(MPI_COMM_WORLD,npes,ierr) +! call MPI_Barrier(MPI_COMM_WORLD, ierr) + + ! Create a new communicator with MPI_Comm_split + color=1 ! just create an communicator now for the whole processes + call MPI_Comm_split(MPI_COMM_WORLD, color, mype, mpi_comm_comp, ierr) + call MPI_COMM_SIZE(mpi_comm_comp,npes,ierr) + + rTYPE = MPI_REAL + dTYPE = MPI_DOUBLE + iTYPE = MPI_INTEGER + +!*** +!*** Analysis grid +!*** + + nx = mod(mype,nxm)+1 + my = (mype/nxm)+1 + +!*** +!*** Define PEs that handle high generations +!*** + + mype_hgen=-1 + my_hgen=-1 + + if( mype < maxpe_filt-nxy(1)) then + mype_hgen=mype+nxy(1) + endif + do g=1,gm + if(maxpe_fgen(g-1)<= mype_hgen .and. mype_hgen< maxpe_fgen(g)) then + my_hgen=g + endif + enddo + l_hgen = mype_hgen >-1 + +!*** +!*** Chars +!*** + write(c_mype,1000) mype + 1000 format(i5.5) + +!----------------------------------------------------------------------- +! + call MPI_BARRIER(mpi_comm_comp,ierr) +! +!----------------------------------------------------------------------- +!*** +!*** Define group communicator for higher generations +!*** +! +! Associate a group with communicator this@mpi_comm_comp +! + call MPI_COMM_GROUP(mpi_comm_comp,group_world,ierr) +! +! Create a new group out of exising group +! + do nf = 1,npes_filt + out_ranks(nf)=nf-1 + enddo + + call MPI_GROUP_INCL(group_world,npes_filt,out_ranks,group_work,ierr) +! +! Now create a new communicator associated with new group +! + call MPI_COMM_CREATE(mpi_comm_comp, group_work, mpi_comm_work, ierr) + + if( mype < npes_filt) then + + call MPI_COMM_RANK(mpi_comm_work,mype_gr,ierr) + call MPI_COMM_SIZE(mpi_comm_work,npes_gr,ierr) + + else + + mype_gr= -1 + npes_gr= npes_filt + + endif + +!----------------------------------------------------------------------- +! + call MPI_BARRIER(mpi_comm_comp,ierr) +! +!----------------------------------------------------------------------- +endsubroutine init_mg_MPI + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine barrierMPI(this) +!*********************************************************************** +! ! +! Call barrier for all ! +! ! +!*********************************************************************** +use mpi + +implicit none +class(mg_parameter_type),target::this +integer(i_kind):: ierr +include "type_parameter_locpointer.inc" +include "type_parameter_point2this.inc" +!----------------------------------------------------------------------- + + call MPI_BARRIER(mpi_comm_comp,ierr) + +!----------------------------------------------------------------------- +endsubroutine barrierMPI + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine finishMPI(this) +!*********************************************************************** +! ! +! Finalize MPI ! +! ! +!*********************************************************************** +use mpi + +implicit none +class(mg_parameter_type),target::this +! +! don't need mpi_finalize if mgbf is a lib to be called from outside +! + call MPI_FINALIZE(this%ierr) + stop +! +!----------------------------------------------------------------------- +endsubroutine finishMPI + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_mppstuff + diff --git a/src/mgbf/mg_parameter.f90 b/src/mgbf/mg_parameter.f90 new file mode 100644 index 0000000000..d4b12a477e --- /dev/null +++ b/src/mgbf/mg_parameter.f90 @@ -0,0 +1,934 @@ +module mg_parameter +!$$$ submodule documentation block +! . . . . +! module: mg_parameter +! prgmmr: rancic org: NCEP/EMC date: 2022 +! +! abstract: Set resolution, grid and decomposition (offset version) +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! init_mg_parameter - +! def_maxgen - +! def_ngens - +! +! Functions Included: +! +! remarks: +! ixm(1)=nxm, jym(1)=nym +! If mod(nxm,2)=0 then mod(im0,2)=0 +! If mod(nxm,2)>0 then mod(im0,8)=0 (for 4 generations) +! (This will keep the right boundary of all decompmisitions +! at same physical location) +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use kinds, only: i_kind,r_kind +use jp_pietc, only: u1 + +implicit none +type:: mg_parameter_type +!----------------------------------------------------------------------- +!*** +!*** Namelist parameters +!*** +real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 +real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +integer(i_kind):: mgbf_proc +logical:: mgbf_line +integer(i_kind):: nxPE,nyPE,im_filt,jm_filt +logical:: lquart,lhelm + +!*** +!*** Number of generations +!*** +integer(i_kind):: gm +integer(i_kind):: gm_max + +!*** +!*** Horizontal resolution +!*** + +! +! Original number of data on GSI analysis grid +! +integer(i_kind):: nA_max0 +integer(i_kind):: mA_max0 + +! +! Global number of data on Analysis grid +! +integer(i_kind):: nm0 +integer(i_kind):: mm0 + +! +! Number of PEs on Analysis grid +! +integer(i_kind):: nxm +integer(i_kind):: nym + +! +! Number of data on local Analysis grid +! +integer(i_kind):: nm +integer(i_kind):: mm + +! +! Number of data on global Filter grid +! +integer(i_kind):: im00 +integer(i_kind):: jm00 + +! +! Number of data on local Filter grid +! +integer(i_kind):: im +integer(i_kind):: jm + +! +! Initial index on local Filter grid +! +integer(i_kind):: i0 +integer(i_kind):: j0 +! +! Initial index on local analysis grid +! +integer(i_kind):: n0 +integer(i_kind):: m0 + +! +! Halo on local Filter grid +! +integer(i_kind):: ib +integer(i_kind):: jb + +! +! Halo on local Analysis grid +! +integer(i_kind):: nb +integer(i_kind):: mb + +integer(i_kind):: hx,hy,hz +integer(i_kind):: p +integer(i_kind):: nh,nfil +real(r_kind):: pasp01,pasp02,pasp03 +real(r_kind):: pee2,rmom2_1,rmom2_2,rmom2_3,rmom2_4 + +integer, allocatable, dimension(:):: maxpe_fgen +integer, allocatable, dimension(:):: ixm,jym,nxy +integer, allocatable, dimension(:):: im0,jm0 +integer, allocatable, dimension(:):: Fimax,Fjmax +integer, allocatable, dimension(:):: FimaxL,FjmaxL + +integer(i_kind):: npes_filt +integer(i_kind):: maxpe_filt + +integer(i_kind):: imL,jmL +integer(i_kind):: imH,jmH +integer(i_kind):: lm_a ! number of vertical layers in analysis fields +integer(i_kind):: lm ! number of vertical layers in filter grids +integer(i_kind):: km2 ! number of 2d variables for filtering +integer(i_kind):: km3 ! number of 3d variables for filtering +integer(i_kind):: n_ens ! number of ensemble members +integer(i_kind):: km_a ! total number of horizontal levels for analysis +integer(i_kind):: km_all ! total number of k levels of ensemble for filtering +integer(i_kind):: km_a_all ! total number of k levels of ensemble +integer(i_kind):: km2_all ! total number of k horizontal levels of ensemble for filtering +integer(i_kind):: km3_all ! total number of k vertical levels of ensemble +logical :: l_loc ! logical flag for localization +logical :: l_filt_g1 ! logical flag for filtering of generation one +logical :: l_lin_vertical ! logical flag for linear interpolation in vertcial +logical :: l_lin_horizontal ! logical flag for linear interpolation in horizontal +logical :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +logical :: l_new_map ! logical flag for new mapping between analysis and filter grid +logical :: l_vertical_filter ! logical flag for vertical filtering +integer(i_kind):: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind):: km_4 +integer(i_kind):: km_16 +integer(i_kind):: km_64 + +real(r_kind):: lengthx,lengthy,xa0,ya0,xf0,yf0 +real(r_kind):: dxf,dyf,dxa,dya + +integer(i_kind):: npadx ! x padding on analysis grid +integer(i_kind):: mpady ! y padding on analysis grid + +integer(i_kind):: ipadx ! x padding on filter decomposition +integer(i_kind):: jpady ! y padding on filter deocmposition + +! +! Just for standalone test +! +logical:: ldelta + +!from mg_mppstuff.f90 +character(len=5):: c_mype +integer(i_kind):: mype +integer(i_kind):: npes,iTYPE,rTYPE,dTYPE,mpi_comm_comp,ierr,ierror +integer(i_kind):: mpi_comm_work,group_world,group_work +integer(i_kind):: mype_gr,npes_gr +integer(i_kind):: my_hgen +integer(i_kind):: mype_hgen +logical:: l_hgen +integer(i_kind):: nx,my +!from mg_domain.f90 +logical,dimension(2):: Flwest,Fleast,Flnorth,Flsouth +integer(i_kind),dimension(2):: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w +integer(i_kind),dimension(2):: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw +logical,dimension(2):: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne +integer(i_kind),dimension(2):: Fitarg_up +integer(i_kind):: itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +integer(i_kind):: itarg_wA,itarg_eA,itarg_sA,itarg_nA +logical:: lwestA,leastA,lsouthA,lnorthA +integer(i_kind):: ix,jy +integer(i_kind),dimension(2):: mype_filt +!from mg_domain_loc.f90 +integer(i_kind):: nsq21,nsq32,nsq43 +logical,dimension(4):: Flsouth_loc,Flnorth_loc,Flwest_loc,Fleast_loc +integer(i_kind),dimension(4):: Fitarg_s_loc,Fitarg_n_loc,Fitarg_w_loc,Fitarg_e_loc +integer(i_kind),dimension(4):: Fitargup_loc12 +integer(i_kind),dimension(4):: Fitargup_loc23 +integer(i_kind),dimension(4):: Fitargup_loc34 +integer(i_kind):: itargdn_sw_loc21,itargdn_se_loc21,itargdn_nw_loc21,itargdn_ne_loc21 +integer(i_kind):: itargdn_sw_loc32,itargdn_se_loc32,itargdn_nw_loc32,itargdn_ne_loc32 +integer(i_kind):: itargdn_sw_loc43,itargdn_se_loc43,itargdn_nw_loc43,itargdn_ne_loc43 +logical:: lsendup_sw_loc,lsendup_se_loc,lsendup_nw_loc,lsendup_ne_loc + +contains + procedure :: init_mg_parameter +!from mg_mppstuff.f90 + procedure :: init_mg_MPI + procedure :: finishMPI + procedure :: barrierMPI +!from mg_domain.f90 + procedure :: init_mg_domain + procedure :: init_domain + procedure :: init_topology_2d + procedure :: real_itarg +!from mg_domain_loc.f90 + procedure :: init_domain_loc + procedure :: sidesend_loc + procedure :: targup_loc + procedure :: targdn21_loc + procedure :: targdn32_loc + procedure :: targdn43_loc +!from jp_pbfil.f90 + generic :: cholaspect => cholaspect1,cholaspect2,cholaspect3,cholaspect4 + procedure,nopass :: cholaspect1,cholaspect2,cholaspect3,cholaspect4 + generic :: getlinesum => getlinesum1,getlinesum2,getlinesum3 + procedure :: getlinesum1,getlinesum2,getlinesum3 + generic :: rbeta => rbeta1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4 + procedure:: rbeta1,rbeta2,rbeta3,rbeta4,vrbeta1,vrbeta2,vrbeta3,vrbeta4 + generic :: rbetaT => rbeta1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t + procedure:: rbeta1t,rbeta2t,rbeta3t,rbeta4t,vrbeta1t,vrbeta2t,vrbeta3t,vrbeta4t +end type mg_parameter_type + +interface +!from mg_mppstuff.f90 + module subroutine init_mg_MPI(this) + class(mg_parameter_type),target :: this + end subroutine + module subroutine finishMPI(this) + class(mg_parameter_type),target :: this + end subroutine + module subroutine barrierMPI(this) + class(mg_parameter_type),target :: this + end subroutine +!from mg_domain.f90 + module subroutine init_mg_domain(this) + class(mg_parameter_type)::this + end subroutine + module subroutine init_domain(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine init_topology_2d(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine real_itarg (this,itarg) + class(mg_parameter_type),target::this + integer(i_kind), intent(inout):: itarg + end subroutine +!from mg_domain_loc.f90 + module subroutine init_domain_loc(this) + class(mg_parameter_type)::this + end subroutine + module subroutine sidesend_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targup_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targdn21_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targdn32_loc(this) + class(mg_parameter_type),target::this + end subroutine + module subroutine targdn43_loc(this) + class(mg_parameter_type),target::this + end subroutine +!from jp_pbfil.f90 + module subroutine cholaspect1(lx,mx, el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx + real(dp),dimension(1,1,lx:mx),intent(inout):: el + end subroutine + module subroutine cholaspect2(lx,mx, ly,my, el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx, ly,my + real(dp),dimension(2,2,lx:mx,ly:my),intent(inout):: el + real(dp),dimension(2,2):: tel + end subroutine + module subroutine cholaspect3(lx,mx, ly,my, lz,mz, el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx, ly,my, lz,mz + real(dp),dimension(3,3,lx:mx,ly:my,lz:mz),intent(inout):: el + real(dp),dimension(3,3):: tel + end subroutine + module subroutine cholaspect4(lx,mx, ly,my, lz,mz, lw,mw,el) + use kinds, only: dp=>r_kind + integer, intent(in ):: lx,mx, ly,my, lz,mz, lw,mw + real(dp),dimension(4,4,lx:mx,ly:my,lz:mz,lw:mw),intent(inout):: el + real(dp),dimension(4,4):: tel + end subroutine + module subroutine getlinesum1(this,hx,lx,mx, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( lx:mx),intent( out):: ss + end subroutine + module subroutine getlinesum2(this,hx,lx,mx, hy,ly,my, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( lx:mx,ly:my),intent( out):: ss + end subroutine + module subroutine getlinesum3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( lx:mx,ly:my,lz:mz),intent( out):: ss + end subroutine + module subroutine getlinesum4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el, ss) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( lx:mx,ly:my,lz:mz,Lw:Mw),intent( out):: ss + end subroutine + module subroutine rbeta1(this,hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx + real(dp),dimension(Lx:Mx),intent(in ):: el + real(dp),dimension(Lx:Mx),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine rbeta2(this,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine rbeta3(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine rbeta4(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine + module subroutine rbeta1T(this,hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( Lx:Mx),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine rbeta2T(this,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine rbeta3T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine rbeta4T(this,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine + module subroutine vrbeta1(this,nv,hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv,hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( Lx:Mx),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine vrbeta2(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine vrbeta3(this,nv, hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine vrbeta4(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss,a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine + module subroutine vrbeta1T(this,nv, hx,lx,mx, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv,hx,Lx,mx + real(dp),dimension(1,1,Lx:Mx),intent(in ):: el + real(dp),dimension( Lx:Mx),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx),intent(inout):: a + end subroutine + module subroutine vrbeta2T(this,nv,hx,lx,mx, hy,ly,my, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my + real(dp),dimension(2,2,Lx:Mx,Ly:My),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy),intent(inout):: a + end subroutine + module subroutine vrbeta3T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz + real(dp),dimension(3,3,Lx:Mx,Ly:My,Lz:Mz),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz),intent(inout):: a + end subroutine + module subroutine vrbeta4T(this,nv,hx,lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw, el,ss, a) + use kinds, only: dp=>r_kind + class(mg_parameter_type)::this + integer, intent(in ):: nv, hx,Lx,mx, hy,ly,my, hz,lz,mz, hw,lw,mw + real(dp),dimension(4,4,Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: el + real(dp),dimension( Lx:Mx,Ly:My,Lz:Mz,Lw:Mw),intent(in ):: ss + real(dp),dimension(nv,lx-hx:mx+hx,ly-hy:my+hy,lz-hz:mz+hz,lw-hw:mw+hw),intent(inout):: a + end subroutine +end interface + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine init_mg_parameter(this,inputfilename) +!**********************************************************************! +! ! +! Initialize .... ! +! ! +!**********************************************************************! +implicit none +class (mg_parameter_type),target:: this +integer(i_kind):: g +character(*):: inputfilename + +! Namelist parameters as local variable +real(r_kind):: mg_ampl01,mg_ampl02,mg_ampl03 +real(r_kind):: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +integer(i_kind):: mgbf_proc +logical:: mgbf_line +integer(i_kind):: nxPE,nyPE,im_filt,jm_filt +logical:: lquart,lhelm +logical:: ldelta + +integer(i_kind):: lm_a ! number of vertical layers in analysis fields +integer(i_kind):: lm ! number of vertical layers in filter grids +integer(i_kind):: km2 ! number of 2d variables for filtering +integer(i_kind):: km3 ! number of 3d variables for filtering +integer(i_kind):: n_ens ! number of ensemble members +logical :: l_loc ! logical flag for localization +logical :: l_filt_g1 ! logical flag for filtering of generation one +logical :: l_lin_vertical ! logical flag for linear interpolation in vertcial +logical :: l_lin_horizontal ! logical flag for linear interpolation in horizontal +logical :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +logical :: l_new_map ! logical flag for new mapping between analysis and filter grid +logical :: l_vertical_filter ! logical flag for vertical filtering +integer(i_kind):: gm_max + +! Global number of data on Analysis grid +integer(i_kind):: nm0 +integer(i_kind):: mm0 + +integer(i_kind):: hx,hy,hz +integer(i_kind):: p + + namelist /parameters_mgbeta/ mg_ampl01,mg_ampl02,mg_ampl03 & + ,mg_weig1,mg_weig2,mg_weig3,mg_weig4 & + ,hx,hy,hz,p & + ,mgbf_line,mgbf_proc & + ,lm_a,lm & + ,km2,km3 & + ,n_ens & + ,l_loc & + ,l_filt_g1 & + ,l_lin_vertical & + ,l_lin_horizontal & + ,l_quad_horizontal & + ,l_new_map & + ,l_vertical_filter & + ,ldelta,lquart,lhelm & + ,gm_max & + ,nm0,mm0 & + ,nxPE,nyPE,im_filt,jm_filt +! + open(unit=10,file=inputfilename,status='old',action='read') + read(10,nml=parameters_mgbeta) + close(unit=10) +! +!----------------------------------------------------------------- +!for safety, copy all namelist loc vars to them of this object + this%mg_ampl01=mg_ampl01 + this%mg_ampl02=mg_ampl02 + this%mg_ampl03=mg_ampl03 + this%mg_weig1=mg_weig1 + this%mg_weig2=mg_weig2 + this%mg_weig3=mg_weig3 + this%mg_weig4=mg_weig4 + this%hx=hx + this%hy=hy + this%hz=hz + this%p =p + this%mgbf_line=mgbf_line + this%mgbf_proc=mgbf_proc + this%lm_a=lm_a + this%lm=lm + this%km2=km2 + this%km3=km3 + this%n_ens=n_ens + this%l_loc=l_loc + this%l_filt_g1=l_filt_g1 + this%l_lin_vertical=l_lin_vertical + this%l_lin_horizontal=l_lin_horizontal + this%l_quad_horizontal=l_quad_horizontal + this%l_new_map=l_new_map + this%l_vertical_filter=l_vertical_filter + this%ldelta=ldelta + this%lquart=lquart + this%lhelm=lhelm + this%nm0=nm0 + this%mm0=mm0 + this%nxPE=nxPE + this%nyPE=nyPE + this%im_filt=im_filt + this%jm_filt=jm_filt + + this%nxm = nxPE + this%nym = nyPE + + this%im = im_filt + this%jm = jm_filt + +!----------------------------------------------------------------- +! +! +! For 168 PES +! +! nxm = 14 +! nym = 12 +! +! For 256 PES +! +! nxm = 16 +! nym = 16 +! +! For 336 PES +! +! nxm = 28 +! nym = 12 +! +! For 448 PES +! +! nxm = 28 +! nym = 16 +! +! For 512 PES +! +! nxm = 32 +! nym = 16 +! +! For 704 PES +! +! nxm = 32 +! nym = 22 +! +! For 768 PES +! +! nxm = 32 +! nym = 24 +! +! For 924 PES +! +! nxm = 28 +! nym = 33 +! +! For 1056 PES +! +! nxm = 32 +! nym = 33 +! +! For 1408 PES +! +! nxm = 32 +! nym = 44 +! +! For 1848 PES +! +! nxm = 56 +! nym = 33 +! +! For 2464 PES +! +! nxm = 56 +! nym = 44 + +! +! Define total number of horizontal levels in the case of ensemble +! + + this%km_a = this%km2+this%lm_a*this%km3 + this%km = this%km2+this%lm *this%km3 + + this%km_a_all = this%km_a * this%n_ens + this%km_all = this%km * this%n_ens + + this%km2_all = this%km2 * this%n_ens + this%km3_all = this%km3 * this%n_ens + + this%km_4 = this%km/4 + this%km_16 = this%km/16 + this%km_64 = this%km/64 + +! +! Define maximum number of generations 'gm' +! + + call def_maxgen(this%nxm,this%nym,this%gm) + +! Restrict to gm_max + + if(this%gm>gm_max) then + this%gm=gm_max + endif + if(this%nxm*this%nym<=1) then + this%gm=gm_max + endif + +!*** +!*** Analysis grid +!*** + +! +! Number of grid intervals on GSI grid for the reduced RTMA domain +! before padding +! + this%nA_max0 = 1792 + this%mA_max0 = 1056 + +! +! Number of grid points on the analysis grid after padding +! + + this%nm = this%nm0/this%nxm + this%mm = this%mm0/this%nym + +!*** +!*** Filter grid +!*** + +! im = nm +! jm = mm + +! +! For 168 PES +! +! im = 120 +! jm = 80 +! +! For 256 PES +! +! im = 96 +! jm = 64 +! +! im = 88 +! jm = 56 +! +! For 336 PES +! +! im = 56 +! jm = 80 +! +! For 448 PES +! +! im = 56 +! jm = 64 +! +! For 512 PES +! +! im = 48 +! jm = 64 +! +! For 704 PES +! +! im = 48 +! jm = 40 +! +! For 768 PES +! +! im = 48 +! jm = 40 +! +! For 924 PES +! +! im = 56 +! jm = 24 +! +! For 1056 PES +! +! im = 48 +! jm = 24 +! +! For 1408 PES +! +! im = 48 +! jm = 20 +! +! For 1848 PES +! +! im = 28 +! jm = 24 +! +! For 2464 PES +! +! im = 28 +! jm = 20 + + this%im00 = this%nxm*this%im + this%jm00 = this%nym*this%jm + + this%n0 = 1 + this%m0 = 1 + + this%i0 = 1 + this%j0 = 1 + +! +! Make sure that nm0 and mm0 and divisibvle with nxm and nym +! + if(this%nm*this%nxm /= this%nm0 ) then + write(17,*) 'nm,nxm,nm0=',this%nm,this%nxm,this%nm0 + stop 'nm0 is not divisible by nxm' + endif + + if(this%mm*this%nym /= this%mm0 ) then + write(17,*) 'mm,nym,mm0=',this%mm,this%nym,this%mm0 + stop 'mm0 is not divisible by nym' + endif + +! +! Set number of processors at higher generations +! + + allocate(this%ixm(this%gm)) + allocate(this%jym(this%gm)) + allocate(this%nxy(this%gm)) + allocate(this%maxpe_fgen(0:this%gm)) + allocate(this%im0(this%gm)) + allocate(this%jm0(this%gm)) + allocate(this%Fimax(this%gm)) + allocate(this%Fjmax(this%gm)) + allocate(this%FimaxL(this%gm)) + allocate(this%FjmaxL(this%gm)) + + call def_ngens(this%ixm,this%gm,this%nxm) + call def_ngens(this%jym,this%gm,this%nym) + + do g=1,this%gm + this%nxy(g)=this%ixm(g)*this%jym(g) + enddo + + this%maxpe_fgen(0)= 0 + do g=1,this%gm + this%maxpe_fgen(g)=this%maxpe_fgen(g-1)+this%nxy(g) + enddo + + this%maxpe_filt=this%maxpe_fgen(this%gm) + this%npes_filt=this%maxpe_filt-this%nxy(1) + + this%im0(1)=this%im00 + do g=2,this%gm + this%im0(g)=this%im0(g-1)/2 + enddo + + this%jm0(1)=this%jm00 + do g=2,this%gm + this%jm0(g)=this%jm0(g-1)/2 + enddo + + do g=1,this%gm + this%Fimax(g)=this%im0(g)-this%im*(this%ixm(g)-1) + this%Fjmax(g)=this%jm0(g)-this%jm*(this%jym(g)-1) + enddo + + do g=1,this%gm + this%FimaxL(g)=this%Fimax(g)/2 + this%FjmaxL(g)=this%Fjmax(g)/2 + enddo + +!*** +!*** Filter related parameters +!** + this%lengthx = 1.*this%nm ! arbitrary chosen scale of the domain + this%lengthy = 1.*this%mm ! arbitrary chosen scale of the domain + + this%ib=6 + this%jb=6 + + this%dxa =this%lengthx/this%nm + this%dxf = this%lengthx/this%im + this%nb = 2*this%dxf/this%dxa + + this%dya = this%lengthy/this%mm + this%dyf = this%lengthy/this%jm + this%mb = 2*this%dyf/this%dya + + this%xa0 = this%dxa*0.5 + this%ya0 = this%dya*0.5 + + this%xf0 = this%dxf*0.5 + this%yf0 = this%dyf*0.5 + + this%imL=this%im/2 + this%jmL=this%jm/2 + + this%imH=this%im0(this%gm) + this%jmH=this%jm0(this%gm) + + this%pasp01 = mg_ampl01 + this%pasp02 = mg_ampl02 + this%pasp03 = mg_ampl03 + + this%nh= max(hx,hy,hz) + this%nfil = this%nh + 2 + + this%pee2=this%p*2 + this%rmom2_1=u1/sqrt(this%pee2+3) + this%rmom2_2=u1/sqrt(this%pee2+4) + this%rmom2_3=u1/sqrt(this%pee2+5) + this%rmom2_4=u1/sqrt(this%pee2+6) + +!---------------------------------------------------------------------- +end subroutine init_mg_parameter + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine def_maxgen & +!********************************************************************** +! ! +! Given number of PEs in x and y direction decides what is the ! +! maximum number of generations that a multigrid scheme can support ! +! ! +! M. Rancic 2020 ! +!********************************************************************** +(nxm,nym,gm) +!---------------------------------------------------------------------- +implicit none +integer, intent(in):: nxm,nym +integer, intent(out):: gm +integer:: npx,npy,gx,gy + + npx = nxm; gx=1 + Do + npx = (npx + 1)/2 + gx = gx + 1 + if(npx == 1) exit + end do + + npy = nym; gy=1 + Do + npy = (npy + 1)/2 + gy = gy + 1 + if(npy == 1) exit + end do + + gm = Min(gx,gy) + + +!---------------------------------------------------------------------- +endsubroutine def_maxgen + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +subroutine def_ngens & +!*********************************************************************! +! ! +! Given number of generations, find number of PEs is s direction ! +! ! +! M. Rancic 2020 ! +!*********************************************************************! +(nsm,gm,nsm0) +!---------------------------------------------------------------------- +implicit none +integer, intent(in):: gm,nsm0 +integer, dimension(gm), intent(out):: nsm +integer:: g +!---------------------------------------------------------------------- + + nsm(1)=nsm0 + Do g=2,gm + nsm(g) = (nsm(g-1) + 1)/2 + end do + +!---------------------------------------------------------------------- +endsubroutine def_ngens + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module mg_parameter diff --git a/src/mgbf/mg_timers.f90 b/src/mgbf/mg_timers.f90 new file mode 100644 index 0000000000..0905d4d867 --- /dev/null +++ b/src/mgbf/mg_timers.f90 @@ -0,0 +1,218 @@ +module mg_timers +!$$$ submodule documentation block +! . . . . +! module: mg_timers +! prgmmr: jovic org: date: 2017 +! +! abstract: Measure cpu and wallclock timing +! +! module history log: +! 2020 rancic - adjusted +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! btim - +! etim - +! print_mg_timers - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + + use mpi + use kinds, only: r_kind,i_kind + implicit none + + private + + public :: btim, etim, print_mg_timers + + type timer + logical :: running = .false. + real(r_kind) :: start_clock = 0.0 + real(r_kind) :: start_cpu = 0.0 + real(r_kind) :: time_clock = 0.0 + real(r_kind) :: time_cpu = 0.0 + end type timer + + type(timer),save,public :: total_tim + type(timer),save,public :: init_tim + type(timer),save,public :: output_tim + type(timer),save,public :: dynamics_tim + type(timer),save,public :: upsend_tim + type(timer),save,public :: upsend1_tim + type(timer),save,public :: upsend2_tim + type(timer),save,public :: upsend3_tim + type(timer),save,public :: an2filt_tim + type(timer),save,public :: filt2an_tim + type(timer),save,public :: weight_tim + type(timer),save,public :: hfiltT_tim + type(timer),save,public :: vfiltT_tim + type(timer),save,public :: vadv1_tim + type(timer),save,public :: hfilt_tim + type(timer),save,public :: vfilt_tim + type(timer),save,public :: adv2_tim + type(timer),save,public :: vtoa_tim + type(timer),save,public :: dnsend_tim + type(timer),save,public :: dnsend1_tim + type(timer),save,public :: dnsend2_tim + type(timer),save,public :: dnsend3_tim + type(timer),save,public :: update_tim + type(timer),save,public :: physics_tim + type(timer),save,public :: radiation_tim + type(timer),save,public :: convection_tim + type(timer),save,public :: turbulence_tim + type(timer),save,public :: microphys_tim + type(timer),save,public :: pack_tim + type(timer),save,public :: arrn_tim + type(timer),save,public :: aintp_tim + type(timer),save,public :: intp_tim + type(timer),save,public :: bocoT_tim + type(timer),save,public :: boco_tim + + integer, parameter, public :: print_clock = 1, & + print_cpu = 2, & + print_clock_pct = 3, & + print_cpu_pct = 4 + +contains + +!----------------------------------------------------------------------- + subroutine btim(t) + implicit none + type(timer), intent(inout) :: t + + if (t%running) then + write(0,*)'btim: timer is already running' + STOP + end if + t%running = .true. + + t%start_clock = wtime() + t%start_cpu = ctime() + + endsubroutine btim +!----------------------------------------------------------------------- + subroutine etim(t) + implicit none + type(timer), intent(inout) :: t + real(r_kind) :: wt, ct + + wt = wtime() + ct = ctime() + + if (.not.t%running) then + write(0,*)'etim: timer is not running' + STOP + end if + t%running = .false. + + t%time_clock = t%time_clock + (wt - t%start_clock) + t%time_cpu = t%time_cpu + (ct - t%start_cpu) + t%start_clock = 0.0 + t%start_cpu = 0.0 + + endsubroutine etim +!----------------------------------------------------------------------- + subroutine print_mg_timers(filename, print_type,mype) + use mpi + implicit none + integer(i_kind),intent(in):: mype + + character(len=*), intent(in) :: filename + integer, intent(in) :: print_type + + integer :: fh + integer :: ierr + integer(kind=MPI_OFFSET_KIND) :: disp + integer, dimension(MPI_STATUS_SIZE) :: stat + character(len=1024) :: buffer, header + integer :: bufsize + + call MPI_File_open(MPI_COMM_WORLD, filename, & + MPI_MODE_WRONLY + MPI_MODE_CREATE, & + MPI_INFO_NULL, fh, ierr) + + buffer = ' ' + if ( print_type == print_clock ) then + write(buffer,"(I6,12(',',F10.4))") mype, & + init_tim%time_clock, & + upsend_tim%time_clock, & + dnsend_tim%time_clock, & + weight_tim%time_clock, & + hfiltT_tim%time_clock, & + hfilt_tim%time_clock, & + filt2an_tim%time_clock, & + aintp_tim%time_clock, & + intp_tim%time_clock, & + an2filt_tim%time_clock, & + output_tim%time_clock, & + total_tim%time_clock + else if ( print_type == print_cpu ) then + write(buffer,"(I6,14(',',F10.4))") mype, & + init_tim%time_cpu, & + an2filt_tim%time_cpu, & + vfiltT_tim%time_cpu, & + upsend_tim%time_cpu, & + hfiltT_tim%time_cpu, & + bocoT_tim%time_cpu, & + weight_tim%time_cpu, & + boco_tim%time_cpu, & + hfilt_tim%time_cpu, & + dnsend_tim%time_cpu, & + vfilt_tim%time_cpu, & + filt2an_tim%time_cpu, & + output_tim%time_cpu, & + total_tim%time_cpu + end if + + bufsize = LEN(TRIM(buffer)) + 1 + buffer(bufsize:bufsize) = NEW_LINE(' ') + + write(header,"(A6,14(',',A10))") "mype", & + "init", & + "an2filt", & + "vfiltT", & + "upsend", & + "hfiltT", & + "bocoT" , & + "weight", & + "boco", & + "hfilt", & + "dnsend", & + "vfilt", & + "filt2an", & + "output", & + "total" + + header(bufsize:bufsize) = NEW_LINE(' ') + disp = 0 + call MPI_File_write_at(fh, disp, header, bufsize, MPI_BYTE, stat, ierr) + + disp = (mype+1)*bufsize + call MPI_File_write_at(fh, disp, buffer, bufsize, MPI_BYTE, stat, ierr) + + call MPI_File_close(fh, ierr) + + endsubroutine print_mg_timers +!----------------------------------------------------------------------- + function wtime() + use mpi + real(r_kind) :: wtime + wtime = MPI_Wtime() + endfunction wtime +!----------------------------------------------------------------------- + function ctime() + real(r_kind) :: ctime + call CPU_TIME(ctime) + endfunction ctime +!----------------------------------------------------------------------- +end module mg_timers diff --git a/src/mgbf/mg_transfer.f90 b/src/mgbf/mg_transfer.f90 new file mode 100644 index 0000000000..3506c659de --- /dev/null +++ b/src/mgbf/mg_transfer.f90 @@ -0,0 +1,445 @@ +submodule(mg_intstate) mg_transfer +!$$$ submodule documentation block +! . . . . +! module: mg_transfer +! prgmmr: rancic org: NOAA/EMC date: 2021 +! +! abstract: Transfer data between analysis and filter grid +! +! module history log: +! 2023-04-19 lei - object-oriented coding +! 2024-01-11 rancic - optimization for ensemble localization +! 2024-02-20 yokota - refactoring to apply for GSI +! +! Subroutines Included: +! anal_to_filt_all - +! filt_to_anal_all - +! anal_to_filt_all2 - +! filt_to_anal_all2 - +! stack_to_composite - +! composite_to_stack - +! S2C_ens - +! C2S_ens - +! anal_to_filt - +! filt_to_anal - +! +! Functions Included: +! +! remarks: +! +! attributes: +! language: f90 +! machine: +! +!$$$ end documentation block + +use mpi +use mg_timers +use kinds, only: r_kind,i_kind + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +contains +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt_all(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:,:):: A3D +real(r_kind),allocatable,dimension(:,:,:,:):: F3D +real(r_kind),allocatable,dimension(:,:,:):: WORK +integer(i_kind):: L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) +allocate(A3D(km3_all,1:nm,1:mm,lm_a)) +allocate(F3D(km3_all,1:nm,1:mm,lm)) + + call btim(an2filt_tim) + call this%S2C_ens(WORKA,A3D,1,nm,1,mm,lm_a,km_a,km_a_all) + + if(lm_a>lm) then + if(l_lin_vertical) then + call this%l_vertical_adjoint_spec(km3_all,lm_a,lm,1,nm,1,mm,A3D,F3D) + else + call this%lwq_vertical_adjoint_spec(km3_all,lm_a,lm,1,nm,1,mm, & + cvf1,cvf2,cvf3,cvf4,lref,A3D,F3D) + endif + else + + do L=1,lm + F3D(:,:,:,L)=A3D(:,:,:,L) + enddo + + endif + + call this%C2S_ens(F3D,WORK,1,nm,1,mm,lm,km,km_all) + + call this%anal_to_filt(WORK) + call etim(an2filt_tim) + +deallocate(A3D,F3D,WORK) +!---------------------------------------------------------------------- +endsubroutine anal_to_filt_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal_all(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:,:):: A3D +real(r_kind),allocatable,dimension(:,:,:,:):: F3D +real(r_kind),allocatable,dimension(:,:,:):: WORK +integer(i_kind):: L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) +allocate(A3D(km3_all,1:nm,1:mm,lm_a)) +allocate(F3D(km3_all,1:nm,1:mm,lm)) + + call btim(filt2an_tim) + call this%filt_to_anal(WORK) + + call this%S2C_ens(WORK,F3D,1,nm,1,mm,lm,km,km_all) + + if(lm_a>lm) then + if(l_lin_vertical) then + call this%l_vertical_direct_spec(km3_all,lm,lm_a,1,nm,1,mm,F3D,A3D) + else + call this%lwq_vertical_direct_spec(km3_all,lm,lm_a,1,nm,1,mm, & + cvf1,cvf2,cvf3,cvf4,lref,F3D,A3D) + endif + else + + do L=1,lm + A3D(:,:,:,L)=F3D(:,:,:,L) + enddo + + endif + + call this%C2S_ens(A3D,WORKA,1,nm,1,mm,lm_a,km_a,km_a_all) + call etim(filt2an_tim) + +deallocate(A3D,F3D,WORK) +!---------------------------------------------------------------------- +endsubroutine filt_to_anal_all + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt_all2(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:):: WORK +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) + + call btim(an2filt_tim) + if(lm_a>lm) then + call this%l_vertical_adjoint_spec2(km3*n_ens,lm_a,lm,1,nm,1,mm,WORKA,WORK) + else + WORK = WORKA + endif + + call this%anal_to_filt(WORK) + call etim(an2filt_tim) + +deallocate(WORK) +!---------------------------------------------------------------------- +endsubroutine anal_to_filt_all2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal_all2(this,WORKA) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORKA(this%km_a_all,1:this%nm,1:this%mm) +real(r_kind),allocatable,dimension(:,:,:):: WORK +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +allocate(WORK(km_all,1:nm,1:mm)) + + call btim(filt2an_tim) + call this%filt_to_anal(WORK) + + if(lm_a>lm) then + call this%l_vertical_direct_spec2(km3*n_ens,lm,lm_a,1,nm,1,mm,WORK,WORKA) + else + WORKA = WORK + endif + call etim(filt2an_tim) + +deallocate(WORK) +!---------------------------------------------------------------------- +endsubroutine filt_to_anal_all2 + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine stack_to_composite & +!*********************************************************************** +! ! +! Transfer data from stack to composite variables ! +! ! +!*********************************************************************** +(this,ARR_ALL,A2D,A3D) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: ARR_ALL +real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(out):: A3D +real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy) ,intent(out):: A2D +integer(i_kind):: i,j,k,L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do L=1,lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + do k=1,km3 + A3D(k,i,j,L)=ARR_ALL( (k-1)*lm+L,i,j ) + enddo + enddo + enddo + enddo + + do k=1,km2 + A2D(k,:,:)=ARR_ALL(km3*lm+k,:,:) + enddo + +!---------------------------------------------------------------------- +endsubroutine stack_to_composite + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine composite_to_stack & +!*********************************************************************** +! ! +! Transfer data from composite to stack variables ! +! ! +!*********************************************************************** +(this,A2D,A3D,ARR_ALL) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +real(r_kind),dimension(this%km2,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(in):: A2D +real(r_kind),dimension(this%km3,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy,this%lm),intent(in):: A3D +real(r_kind),dimension(this%km ,1-this%hx:this%im+this%hx,1-this%hy:this%jm+this%hy), intent(out):: ARR_ALL +integer(i_kind):: i,j,k,L +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do L=1,lm + do j=1-hy,jm+hy + do i=1-hx,im+hx + do k=1,km3 + ARR_ALL( (k-1)*lm+L,i,j )=A3D(k,i,j,L) + enddo + enddo + enddo + enddo + + do k=1,km2 + ARR_ALL(km3*lm+k,:,:)=A2D(k,:,:) + enddo + +!---------------------------------------------------------------------- +endsubroutine composite_to_stack + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine S2C_ens & +!*********************************************************************** +! ! +! General transfer data from stack to composite variables for ensemble ! +! ! +!*********************************************************************** +(this,ARR_ALL,A3D,imn,imx,jmn,jmx,lmx,kmx,kmx_all) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all +real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(in):: ARR_ALL +real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(out):: A3D +integer(i_kind):: i,j,k,L +integer(i_kind):: n,n_inc +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do n=1,n_ens + n_inc = kmx*(n-1) + + do L=1,lmx + do j=jmn,jmx + do i=imn,imx + do k=1,km3 + A3D(km3*(n-1)+k,i,j,L)=ARR_ALL(n_inc+(k-1)*lmx+L,i,j) + enddo + enddo + enddo + enddo + + enddo +!---------------------------------------------------------------------- +endsubroutine S2C_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine C2S_ens & +!*********************************************************************** +! ! +! General transfer data from composite to stack variables for ensemble ! +! ! +!*********************************************************************** +(this,A3D,ARR_ALL,imn,imx,jmn,jmx,lmx,kmx,kmx_all) +!---------------------------------------------------------------------- +implicit none +class(mg_intstate_type),target::this +integer, intent(in):: imn,imx,jmn,jmx,lmx,kmx,kmx_all +real(r_kind),dimension(this%km3_all,imn:imx,jmn:jmx,lmx),intent(in):: A3D +real(r_kind),dimension(kmx_all,imn:imx,jmn:jmx) ,intent(out):: ARR_ALL +integer(i_kind):: i,j,k,L +integer(i_kind):: n,n_inc +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + do n=1,n_ens + n_inc = kmx*(n-1) + + do L=1,lmx + do j=jmn,jmx + do i=imn,imx + do k=1,km3 + ARR_ALL(n_inc+(k-1)*lmx+L,i,j )= A3D(km3*(n-1)+k,i,j,L) + enddo + enddo + enddo + enddo + + enddo +!---------------------------------------------------------------------- +endsubroutine C2S_ens + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine anal_to_filt(this,WORK) +!*********************************************************************** +! ! +! Transfer data from analysis to first generaton of filter grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) +integer(i_kind):: ibm,jbm +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + VALL=0. + + if(l_lin_horizontal) then + ibm=1 + jbm=1 + call this%lin_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + elseif(l_quad_horizontal) then + ibm=2 + jbm=2 + call this%quad_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + else + ibm=3 + jbm=3 + call this%lsqr_adjoint_offset(WORK,VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,ibm,jbm) + endif + +!*** +!*** Apply adjoint lateral bc on PKF and WKF +!*** + + call this%bocoT_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + +!---------------------------------------------------------------------- +endsubroutine anal_to_filt + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal(this,WORK) +!*********************************************************************** +! ! +! Transfer data from filter to analysis grid ! +! ! +!*********************************************************************** +implicit none +class(mg_intstate_type),target::this +real(r_kind):: WORK(this%km_all,1:this%nm,1:this%mm) +integer(i_kind):: ibm,jbm +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- + + if(l_lin_horizontal) then + ibm=1 + jbm=1 + elseif(l_quad_horizontal) then + ibm=2 + jbm=2 + else + ibm=3 + jbm=3 + endif + +!*** +!*** Supply boundary conditions for VALL +!*** + + call this%boco_2d(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),km_all,im,jm,ibm,jbm) + + if(l_lin_horizontal) then + call this%lin_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + elseif(l_quad_horizontal) then + call this%quad_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + else + call this%lsqr_direct_offset(VALL(1:km_all,1-ibm:im+ibm,1-jbm:jm+jbm),WORK,km_all,ibm,jbm) + endif + +!---------------------------------------------------------------------- +endsubroutine filt_to_anal + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end submodule mg_transfer diff --git a/src/mgbf/type_intstat_locpointer.inc b/src/mgbf/type_intstat_locpointer.inc new file mode 100644 index 0000000000..52cdb687e8 --- /dev/null +++ b/src/mgbf/type_intstat_locpointer.inc @@ -0,0 +1,44 @@ +real(r_kind), dimension(:,:,:),pointer:: V +real(r_kind), dimension(:,:,:),pointer:: VALL +real(r_kind), dimension(:,:,:),pointer:: HALL +real(r_kind), dimension(:,:,:),pointer:: a_diff_f +real(r_kind), dimension(:,:,:),pointer:: a_diff_h +real(r_kind), dimension(:,:,:),pointer:: b_diff_f +real(r_kind), dimension(:,:,:),pointer:: b_diff_h +real(r_kind), dimension(:,:),pointer:: p_eps +real(r_kind), dimension(:,:),pointer:: p_del +real(r_kind), dimension(:,:),pointer:: p_sig +real(r_kind), dimension(:,:),pointer:: p_rho +real(r_kind), dimension(:,:,:),pointer:: paspx +real(r_kind), dimension(:,:,:),pointer:: paspy +real(r_kind), dimension(:,:,:),pointer:: pasp1 +real(r_kind), dimension(:,:,:,:),pointer:: pasp2 +real(r_kind), dimension(:,:,:,:,:),pointer:: pasp3 +real(r_kind), dimension(:,:,:),pointer:: vpasp2 +real(r_kind), dimension(:,:,:),pointer:: hss2 +real(r_kind), dimension(:,:,:,:),pointer:: vpasp3 +real(r_kind), dimension(:,:,:,:),pointer:: hss3 +real(r_kind), dimension(:),pointer:: ssx +real(r_kind), dimension(:),pointer:: ssy +real(r_kind), dimension(:),pointer:: ss1 +real(r_kind), dimension(:,:),pointer:: ss2 +real(r_kind), dimension(:,:,:),pointer:: ss3 +integer(fpi), dimension(:,:,:),pointer:: dixs +integer(fpi), dimension(:,:,:),pointer:: diys +integer(fpi), dimension(:,:,:),pointer:: dizs +integer(fpi), dimension(:,:,:,:),pointer:: dixs3 +integer(fpi), dimension(:,:,:,:),pointer:: diys3 +integer(fpi), dimension(:,:,:,:),pointer:: dizs3 +integer(fpi), dimension(:,:,:,:),pointer:: qcols +integer(i_kind),dimension(:),pointer:: iref,jref +integer(i_kind),dimension(:),pointer:: Lref,Lref_h +real(r_kind),dimension(:),pointer:: cvf1,cvf2,cvf3,cvf4 +real(r_kind),dimension(:),pointer:: cvh1,cvh2,cvh3,cvh4 +real(r_kind),dimension(:),pointer:: cx0,cx1,cx2,cx3 +real(r_kind),dimension(:),pointer:: cy0,cy1,cy2,cy3 +real(r_kind),dimension(:),pointer:: p_coef,q_coef +real(r_kind),dimension(:),pointer:: a_coef,b_coef +real(r_kind),dimension(:,:),pointer:: cf00,cf01,cf02,cf03 & + ,cf10,cf11,cf12,cf13 & + ,cf20,cf21,cf22,cf23 & + ,cf30,cf31,cf32,cf33 diff --git a/src/mgbf/type_intstat_point2this.inc b/src/mgbf/type_intstat_point2this.inc new file mode 100644 index 0000000000..ab8923f059 --- /dev/null +++ b/src/mgbf/type_intstat_point2this.inc @@ -0,0 +1,83 @@ +V=>this%V +VALL=>this%VALL +HALL=>this%HALL + +a_diff_f=>this%a_diff_f +a_diff_h=>this%a_diff_h +b_diff_f=>this%b_diff_f +b_diff_h=>this%b_diff_h + +p_eps=>this%p_eps +p_del=>this%p_del +p_sig=>this%p_sig +p_rho=>this%p_rho +paspx=>this%paspx +paspy=>this%paspy +pasp1=>this%pasp1 +pasp2=>this%pasp2 +pasp3=>this%pasp3 + +vpasp2=>this%vpasp2 +hss2=>this%hss2 +vpasp3=>this%vpasp3 +hss3=>this%hss3 + +ssx=>this%ssx +ssy=>this%ssy +ss1=>this%ss1 +ss2=>this%ss2 +ss3=>this%ss3 + +dixs=>this%dixs +diys=>this%diys +dizs=>this%dizs + +dixs3=>this%dixs3 +diys3=>this%diys3 +dizs3=>this%dizs3 + +qcols=>this%qcols + +iref=>this%iref +jref=>this%jref +Lref=>this%Lref +Lref_h=>this%Lref_h +cvf1=>this%cvf1 +cvf2=>this%cvf2 +cvf3=>this%cvf3 +cvf4=>this%cvf4 +cvh1=>this%cvh1 +cvh2=>this%cvh2 +cvh3=>this%cvh3 +cvh4=>this%cvh4 + +cx0=>this%cx0 +cx1=>this%cx1 +cx2=>this%cx2 +cx3=>this%cx3 +cy0=>this%cy0 +cy1=>this%cy1 +cy2=>this%cy2 +cy3=>this%cy3 + +p_coef=>this%p_coef +q_coef=>this%q_coef +a_coef=>this%a_coef +b_coef=>this%b_coef + +cf00=>this%cf00 +cf01=>this%cf01 +cf02=>this%cf02 +cf03=>this%cf03 +cf10=>this%cf10 +cf11=>this%cf11 +cf12=>this%cf12 +cf13=>this%cf13 +cf20=>this%cf20 +cf21=>this%cf21 +cf22=>this%cf22 +cf23=>this%cf23 +cf30=>this%cf30 +cf31=>this%cf31 +cf32=>this%cf32 +cf33=>this%cf33 diff --git a/src/mgbf/type_parameter_locpointer.inc b/src/mgbf/type_parameter_locpointer.inc new file mode 100644 index 0000000000..7a8f587dd2 --- /dev/null +++ b/src/mgbf/type_parameter_locpointer.inc @@ -0,0 +1,105 @@ +real(r_kind),pointer :: mg_ampl01,mg_ampl02,mg_ampl03 +real(r_kind),pointer:: mg_weig1,mg_weig2,mg_weig3,mg_weig4 +integer(i_kind),pointer:: mgbf_proc +logical,pointer:: mgbf_line +integer(i_kind),pointer:: nxPE,nyPE,im_filt,jm_filt +logical,pointer:: lquart,lhelm +integer(i_kind),pointer:: gm +integer(i_kind),pointer:: gm_max +integer(i_kind),pointer:: nA_max0 +integer(i_kind),pointer:: mA_max0 +integer(i_kind),pointer:: nm0 +integer(i_kind),pointer:: mm0 +integer(i_kind),pointer:: nxm +integer(i_kind),pointer:: nym +integer(i_kind),pointer:: nm +integer(i_kind),pointer:: mm +integer(i_kind),pointer:: im00 +integer(i_kind),pointer:: jm00 +integer(i_kind),pointer:: im +integer(i_kind),pointer:: jm +integer(i_kind),pointer:: i0 +integer(i_kind),pointer:: j0 +integer(i_kind),pointer:: n0 +integer(i_kind),pointer:: m0 +integer(i_kind),pointer:: ib +integer(i_kind),pointer:: jb +integer(i_kind),pointer:: nb +integer(i_kind),pointer:: mb +integer(i_kind),pointer:: hx,hy,hz +integer(i_kind),pointer:: p +integer(i_kind),pointer:: nh,nfil +real(r_kind),pointer:: pasp01,pasp02,pasp03 +real(r_kind),pointer:: pee2,rmom2_1,rmom2_2,rmom2_3,rmom2_4 +integer, pointer, dimension(:):: maxpe_fgen +integer, pointer, dimension(:):: ixm,jym,nxy +integer, pointer, dimension(:):: im0,jm0 +integer, pointer, dimension(:):: Fimax,Fjmax +integer, pointer, dimension(:):: FimaxL,FjmaxL +integer(i_kind),pointer:: npes_filt +integer(i_kind),pointer:: maxpe_filt +integer(i_kind),pointer:: imL,jmL +integer(i_kind),pointer:: imH,jmH +integer(i_kind),pointer:: lm_a ! number of vertical layers in analysis fields +integer(i_kind),pointer:: lm ! number of vertical layers in filter grids +integer(i_kind),pointer:: km2 ! number of 2d variables for filtering +integer(i_kind),pointer:: km3 ! number of 3d variables for filtering +integer(i_kind),pointer:: n_ens ! number of ensemble members +integer(i_kind),pointer:: km_a ! total number of horizontal levels for analysis +integer(i_kind),pointer:: km_all ! total number of k levels of ensemble for filtering +integer(i_kind),pointer:: km_a_all ! total number of k levels of ensemble +integer(i_kind),pointer:: km2_all ! total number of k horizontal levels of ensemble for filtering +integer(i_kind),pointer:: km3_all ! total number of k vertical levels of ensemble +logical,pointer :: l_loc ! logical flag for localization +logical,pointer :: l_filt_g1 ! logical flag for filtering of generation one +logical,pointer :: l_lin_vertical ! logical flag for linear interpolation in vertcial +logical,pointer :: l_lin_horizontal ! logical flag for linear interpolation in horizontal +logical,pointer :: l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +logical,pointer :: l_new_map ! logical flag for new mapping between analysis and filter grid +logical,pointer :: l_vertical_filter ! logical flag for vertical filtering +integer(i_kind),pointer:: km ! number of vertically stacked all variables (km=km2+lm*km3) +integer(i_kind),pointer:: km_4 +integer(i_kind),pointer:: km_16 +integer(i_kind),pointer:: km_64 +real(r_kind),pointer:: lengthx,lengthy,xa0,ya0,xf0,yf0 +real(r_kind),pointer:: dxf,dyf,dxa,dya +integer(i_kind),pointer:: npadx ! x padding on analysis grid +integer(i_kind),pointer:: mpady ! y padding on analysis grid +integer(i_kind),pointer:: ipadx ! x padding on filter decomposition +integer(i_kind),pointer:: jpady ! y padding on filter deocmposition +logical,pointer:: ldelta + +!from mg_mppstuff.f90 +character(len=5),pointer:: c_mype +integer(i_kind),pointer:: mype +integer(i_kind),pointer:: npes,iTYPE,rTYPE,dTYPE,mpi_comm_comp,ierror +integer(i_kind),pointer:: mpi_comm_work,group_world,group_work +integer(i_kind),pointer:: mype_gr,npes_gr +integer(i_kind),pointer:: my_hgen +integer(i_kind),pointer:: mype_hgen +logical,pointer:: l_hgen +integer(i_kind),pointer:: nx,my + +!from mg_domain.f90 +logical,dimension(:),pointer:: Flwest,Fleast,Flnorth,Flsouth +integer(i_kind),dimension(:),pointer:: Fitarg_n,Fitarg_e,Fitarg_s,Fitarg_w +integer(i_kind),dimension(:),pointer:: Fitarg_sw,Fitarg_se,Fitarg_ne,Fitarg_nw +logical,dimension(:),pointer:: Flsendup_sw,Flsendup_se,Flsendup_nw,Flsendup_ne +integer(i_kind),dimension(:),pointer:: Fitarg_up +integer(i_kind),pointer:: itargdn_sw,itargdn_se,itargdn_ne,itargdn_nw +integer(i_kind),pointer:: itarg_wA,itarg_eA,itarg_sA,itarg_nA +logical,pointer:: lwestA,leastA,lsouthA,lnorthA +integer(i_kind),pointer:: ix,jy +integer(i_kind),dimension(:),pointer:: mype_filt + +!from mg_domain_loc.f90 +integer(i_kind),pointer:: nsq21,nsq32,nsq43 +logical,dimension(:),pointer:: Flsouth_loc,Flnorth_loc,Flwest_loc,Fleast_loc +integer(i_kind),dimension(:),pointer:: Fitarg_s_loc,Fitarg_n_loc,Fitarg_w_loc,Fitarg_e_loc +integer(i_kind),dimension(:),pointer:: Fitargup_loc12 +integer(i_kind),dimension(:),pointer:: Fitargup_loc23 +integer(i_kind),dimension(:),pointer:: Fitargup_loc34 +integer(i_kind),pointer:: itargdn_sw_loc21,itargdn_se_loc21,itargdn_nw_loc21,itargdn_ne_loc21 +integer(i_kind),pointer:: itargdn_sw_loc32,itargdn_se_loc32,itargdn_nw_loc32,itargdn_ne_loc32 +integer(i_kind),pointer:: itargdn_sw_loc43,itargdn_se_loc43,itargdn_nw_loc43,itargdn_ne_loc43 +logical,pointer:: lsendup_sw_loc,lsendup_se_loc,lsendup_nw_loc,lsendup_ne_loc diff --git a/src/mgbf/type_parameter_point2this.inc b/src/mgbf/type_parameter_point2this.inc new file mode 100644 index 0000000000..310f183311 --- /dev/null +++ b/src/mgbf/type_parameter_point2this.inc @@ -0,0 +1,189 @@ +mg_ampl01=>this%mg_ampl01 +mg_ampl02=>this%mg_ampl02 +mg_ampl03=>this%mg_ampl03 +mg_weig1=>this%mg_weig1 +mg_weig2=>this%mg_weig2 +mg_weig3=>this%mg_weig3 +mg_weig4=>this%mg_weig4 +mgbf_proc=>this%mgbf_proc +mgbf_line=>this%mgbf_line +nxPE=>this%nxPE +nyPE=>this%nyPE +im_filt=>this%im_filt +jm_filt=>this%jm_filt +lquart=>this%lquart +lhelm=>this%lhelm +gm=>this%gm +gm_max=>this%gm_max +nA_max0=>this%nA_max0 +mA_max0=>this%mA_max0 +nm0=>this%nm0 +mm0=>this%mm0 +nxm=>this%nxm +nym=>this%nym +nm=>this%nm +mm=>this%mm +im00=>this%im00 +jm00=>this%jm00 +im=>this%im +jm=>this%jm +i0=>this%i0 +j0=>this%j0 +n0=>this%n0 +m0=>this%m0 +ib=>this%ib +jb=>this%jb +nb=>this%nb +mb=>this%mb +hx=>this%hx +hy=>this%hy +hz=>this%hz +p=>this%p +nh=>this%nh +nfil=>this%nfil +pasp01=>this%pasp01 +pasp02=>this%pasp02 +pasp03=>this%pasp03 +pee2=>this%pee2 +rmom2_1=>this%rmom2_1 +rmom2_2=>this%rmom2_2 +rmom2_3=>this%rmom2_3 +rmom2_4=>this%rmom2_4 +maxpe_fgen=>this%maxpe_fgen +ixm=>this%ixm +jym=>this%jym +nxy=>this%nxy +im0=>this%im0 +jm0=>this%jm0 +Fimax=>this%Fimax +Fjmax=>this%Fjmax +FimaxL=>this%FimaxL +FjmaxL=>this%FjmaxL +npes_filt=>this%npes_filt +maxpe_filt=>this%maxpe_filt +imL=>this%imL +jmL=>this%jmL +imH=>this%imH +jmH=>this%jmH +lm_a=>this%lm_a ! number of vertical layers in analysis fields +lm=>this%lm ! number of vertical layers in filter grids +km2=>this%km2 ! number of 2d variables for filtering +km3=>this%km3 ! number of 3d variables for filtering +n_ens=>this%n_ens ! number of ensemble members +km_a=>this%km_a ! total number of horizontal levels for analysis +km_all=>this%km_all ! total number of k levels of ensemble for filtering +km_a_all=>this%km_a_all ! total number of k levels of ensemble +km2_all=>this%km2_all ! total number of k horizontal levels of ensemble for filtering +km3_all=>this%km3_all ! total number of k vertical levels of ensemble +l_loc=>this%l_loc ! logical flag for localization +l_filt_g1=>this%l_filt_g1 ! logical flag for filtering of generation one +l_lin_vertical=>this%l_lin_vertical ! logical flag for linear interpolation in vertcial +l_lin_horizontal=>this%l_lin_horizontal ! logical flag for linear interpolation in horizontal +l_quad_horizontal=>this%l_quad_horizontal ! logical flag for quadratic interpolation in horizontal +l_new_map=>this%l_new_map ! logical flag for new mapping between analysis and filter grid +l_vertical_filter=>this%l_vertical_filter ! logical flag for vertical filtering +km=>this%km ! number of vertically stacked all variables (km=km2+lm*km3) +km_4=>this%km_4 +km_16=>this%km_16 +km_64=>this%km_64 +lengthx=>this%lengthx +lengthy=>this%lengthy +xa0=>this%xa0 +ya0=>this%ya0 +xf0=>this%xf0 +yf0=>this%yf0 +dxf=>this%dxf +dyf=>this%dyf +dxa=>this%dxa +dya=>this%dya +npadx=>this%npadx ! x padding on analysis grid +mpady=>this%mpady ! y padding on analysis grid +ipadx=>this%ipadx ! x padding on filter decomposition +jpady=>this%jpady ! y padding on filter deocmposition +ldelta=>this%ldelta + +!from mg_mppstuff.f90 +c_mype=>this%c_mype +mype=>this%mype +npes=>this%npes +iTYPE=>this%iTYPE +rTYPE=>this%rTYPE +dTYPE=>this%dTYPE +mpi_comm_comp=>this%mpi_comm_comp +ierror=>this%ierror +mpi_comm_work=>this%mpi_comm_work +group_world=>this%group_world +group_work=>this%group_work +mype_gr=>this%mype_gr +npes_gr=>this%npes_gr +my_hgen=>this%my_hgen +mype_hgen=>this%mype_hgen +l_hgen=>this%l_hgen +nx=>this%nx +my=>this%my + +!from mg_domain.f90 +Flwest=>this%Flwest +Fleast=>this%Fleast +Flnorth=>this%Flnorth +Flsouth=>this%Flsouth +Fitarg_n=>this%Fitarg_n +Fitarg_e=>this%Fitarg_e +Fitarg_s=>this%Fitarg_s +Fitarg_w=>this%Fitarg_w +Fitarg_sw=>this%Fitarg_sw +Fitarg_se=>this%Fitarg_se +Fitarg_ne=>this%Fitarg_ne +Fitarg_nw=>this%Fitarg_nw +Flsendup_sw=>this%Flsendup_sw +Flsendup_se=>this%Flsendup_se +Flsendup_nw=>this%Flsendup_nw +Flsendup_ne=>this%Flsendup_ne +Fitarg_up=>this%Fitarg_up +itargdn_sw=>this%itargdn_sw +itargdn_se=>this%itargdn_se +itargdn_ne=>this%itargdn_ne +itargdn_nw=>this%itargdn_nw +itarg_wA=>this%itarg_wA +itarg_eA=>this%itarg_eA +itarg_sA=>this%itarg_sA +itarg_nA=>this%itarg_nA +lwestA=>this%lwestA +leastA=>this%leastA +lsouthA=>this%lsouthA +lnorthA=>this%lnorthA +ix=>this%ix +jy=>this%jy +mype_filt=>this%mype_filt + +!from mg_domain_loc.f90 +nsq21=>this%nsq21 +nsq32=>this%nsq32 +nsq43=>this%nsq43 +Flsouth_loc=>this%Flsouth_loc +Flnorth_loc=>this%Flnorth_loc +Flwest_loc=>this%Flwest_loc +Fleast_loc=>this%Fleast_loc +Fitarg_s_loc=>this%Fitarg_s_loc +Fitarg_n_loc=>this%Fitarg_n_loc +Fitarg_w_loc=>this%Fitarg_w_loc +Fitarg_e_loc=>this%Fitarg_e_loc +Fitargup_loc12=>this%Fitargup_loc12 +Fitargup_loc23=>this%Fitargup_loc23 +Fitargup_loc34=>this%Fitargup_loc34 +itargdn_sw_loc21=>this%itargdn_sw_loc21 +itargdn_se_loc21=>this%itargdn_se_loc21 +itargdn_nw_loc21=>this%itargdn_nw_loc21 +itargdn_ne_loc21=>this%itargdn_ne_loc21 +itargdn_sw_loc32=>this%itargdn_sw_loc32 +itargdn_se_loc32=>this%itargdn_se_loc32 +itargdn_nw_loc32=>this%itargdn_nw_loc32 +itargdn_ne_loc32=>this%itargdn_ne_loc32 +itargdn_sw_loc43=>this%itargdn_sw_loc43 +itargdn_se_loc43=>this%itargdn_se_loc43 +itargdn_nw_loc43=>this%itargdn_nw_loc43 +itargdn_ne_loc43=>this%itargdn_ne_loc43 +lsendup_sw_loc=>this%lsendup_sw_loc +lsendup_se_loc=>this%lsendup_se_loc +lsendup_nw_loc=>this%lsendup_nw_loc +lsendup_ne_loc=>this%lsendup_ne_loc