From a8986684a815a9f2602a11e962f8443b78169012 Mon Sep 17 00:00:00 2001 From: "Henry R. Winterbottom" <49202169+HenryWinterbottom-NOAA@users.noreply.github.com> Date: Wed, 31 Jan 2024 09:00:33 -0700 Subject: [PATCH 01/35] Updated detect_machine.sh to be consistent with UFSWM. (#691) Co-authored-by: henrywinterbottom-wxdev --- .../{gsi_discover => gsi_discover.intel} | 0 .../{gsi_gaea.lua => gsi_gaea.intel.lua} | 0 ...si_hercules.lua => gsi_hercules.intel.lua} | 0 .../{gsi_jet.lua => gsi_jet.intel.lua} | 0 .../{gsi_orion.lua => gsi_orion.intel.lua} | 0 modulefiles/{gsi_s4.lua => gsi_s4.intel.lua} | 0 .../{gsi_wcoss2.lua => gsi_wcoss2.intel.lua} | 0 ush/build.sh | 2 +- ush/detect_machine.sh | 76 +++++++++++++++---- ush/sub_discover | 2 +- ush/sub_gaea | 2 +- ush/sub_hercules | 2 +- ush/sub_jet | 2 +- ush/sub_orion | 2 +- ush/sub_wcoss2 | 2 +- 15 files changed, 67 insertions(+), 23 deletions(-) rename modulefiles/{gsi_discover => gsi_discover.intel} (100%) rename modulefiles/{gsi_gaea.lua => gsi_gaea.intel.lua} (100%) rename modulefiles/{gsi_hercules.lua => gsi_hercules.intel.lua} (100%) rename modulefiles/{gsi_jet.lua => gsi_jet.intel.lua} (100%) rename modulefiles/{gsi_orion.lua => gsi_orion.intel.lua} (100%) rename modulefiles/{gsi_s4.lua => gsi_s4.intel.lua} (100%) rename modulefiles/{gsi_wcoss2.lua => gsi_wcoss2.intel.lua} (100%) diff --git a/modulefiles/gsi_discover b/modulefiles/gsi_discover.intel similarity index 100% rename from modulefiles/gsi_discover rename to modulefiles/gsi_discover.intel diff --git a/modulefiles/gsi_gaea.lua b/modulefiles/gsi_gaea.intel.lua similarity index 100% rename from modulefiles/gsi_gaea.lua rename to modulefiles/gsi_gaea.intel.lua diff --git a/modulefiles/gsi_hercules.lua b/modulefiles/gsi_hercules.intel.lua similarity index 100% rename from modulefiles/gsi_hercules.lua rename to modulefiles/gsi_hercules.intel.lua diff --git a/modulefiles/gsi_jet.lua b/modulefiles/gsi_jet.intel.lua similarity index 100% rename from modulefiles/gsi_jet.lua rename to modulefiles/gsi_jet.intel.lua diff --git a/modulefiles/gsi_orion.lua b/modulefiles/gsi_orion.intel.lua similarity index 100% rename from modulefiles/gsi_orion.lua rename to modulefiles/gsi_orion.intel.lua diff --git a/modulefiles/gsi_s4.lua b/modulefiles/gsi_s4.intel.lua similarity index 100% rename from modulefiles/gsi_s4.lua rename to modulefiles/gsi_s4.intel.lua diff --git a/modulefiles/gsi_wcoss2.lua b/modulefiles/gsi_wcoss2.intel.lua similarity index 100% rename from modulefiles/gsi_wcoss2.lua rename to modulefiles/gsi_wcoss2.intel.lua diff --git a/ush/build.sh b/ush/build.sh index 9a280c4e55..a133889eac 100755 --- a/ush/build.sh +++ b/ush/build.sh @@ -24,7 +24,7 @@ source $DIR_ROOT/ush/detect_machine.sh set +x source $DIR_ROOT/ush/module-setup.sh module use $DIR_ROOT/modulefiles -module load gsi_$MACHINE_ID +module load "gsi_${MACHINE_ID}.${COMPILER}" module list set -x diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index ac6c7f58d1..683ee0db7f 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -1,20 +1,30 @@ #!/bin/bash +# The authoritative copy of this script lives in the ufs-weather-model at: +# https://github.com/ufs-community/ufs-weather-model/blob/develop/tests/detect_machine.sh +# If any local modifications are made or new platform support added, +# please consider opening an issue and a PR to the ufs-weather-model +# so that this copy remains in sync with its authoritative source +# +# Thank you for your contribution + +# If the MACHINE_ID variable is set, skip this script. +[[ -n ${MACHINE_ID:-} ]] && return + +# First detect w/ hostname case $(hostname -f) in - adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn - alogin0[1-3].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### acorn + adecflow0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=acorn ;; ### acorn + alogin0[12].acorn.wcoss2.ncep.noaa.gov) MACHINE_ID=acorn ;; ### acorn clogin0[1-9].cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus01-9 clogin10.cactus.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### cactus10 dlogin0[1-9].dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood01-9 dlogin10.dogwood.wcoss2.ncep.noaa.gov) MACHINE_ID=wcoss2 ;; ### dogwood10 - gaea9) MACHINE_ID=gaea ;; ### gaea9 - gaea1[0-6]) MACHINE_ID=gaea ;; ### gaea10-16 - gaea9.ncrc.gov) MACHINE_ID=gaea ;; ### gaea9 - gaea1[0-6].ncrc.gov) MACHINE_ID=gaea ;; ### gaea10-16 + gaea5[1-8]) MACHINE_ID=gaea ;; ### gaea51-58 + gaea5[1-8].ncrc.gov) MACHINE_ID=gaea ;; ### gaea51-58 - hfe0[1-9]) MACHINE_ID=hera ;; ### hera01-9 + hfe0[1-9]) MACHINE_ID=hera ;; ### hera01-09 hfe1[0-2]) MACHINE_ID=hera ;; ### hera10-12 hecflow01) MACHINE_ID=hera ;; ### heraecflow01 @@ -25,24 +35,58 @@ case $(hostname -f) in Orion-login-[1-4].HPC.MsState.Edu) MACHINE_ID=orion ;; ### orion1-4 - Hercules-login-[1-4].HPC.MsState.Edu) MACHINE_ID=hercules ;; ### hercules1-4 - - cheyenne[1-6].cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 - cheyenne[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 - chadmin[1-6].ib0.cheyenne.ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 - chadmin[1-6].ucar.edu) MACHINE_ID=cheyenne ;; ### cheyenne1-6 + [Hh]ercules-login-[1-4].[Hh][Pp][Cc].[Mm]s[Ss]tate.[Ee]du) MACHINE_ID=hercules ;; ### hercules1-4 login[1-4].stampede2.tacc.utexas.edu) MACHINE_ID=stampede ;; ### stampede1-4 login0[1-2].expanse.sdsc.edu) MACHINE_ID=expanse ;; ### expanse1-2 discover3[1-5].prv.cube) MACHINE_ID=discover ;; ### discover31-35 + *) MACHINE_ID=UNKNOWN ;; # Unknown platform esac +if [[ ${MACHINE_ID} == "UNKNOWN" ]]; then + case ${PW_CSP:-} in + "aws" | "google" | "azure") MACHINE_ID=noaacloud ;; + *) PW_CSP="UNKNOWN" + esac +fi + # Overwrite auto-detect with MACHINE if set MACHINE_ID=${MACHINE:-${MACHINE_ID}} -# Append compiler (only on machines that have multiple compilers) -if [ $MACHINE_ID = hera ] || [ $MACHINE_ID = cheyenne ]; then - MACHINE_ID=${MACHINE_ID}.${COMPILER} +# If MACHINE_ID is no longer UNKNNOWN, return it +if [[ "${MACHINE_ID}" != "UNKNOWN" ]]; then + return +fi + +# Try searching based on paths since hostname may not match on compute nodes +if [[ -d /lfs/h3 ]]; then + # We are on NOAA Cactus or Dogwood + MACHINE_ID=wcoss2 +elif [[ -d /lfs/h1 && ! -d /lfs/h3 ]]; then + # We are on NOAA TDS Acorn + MACHINE_ID=acorn +elif [[ -d /mnt/lfs1 ]]; then + # We are on NOAA Jet + MACHINE_ID=jet +elif [[ -d /scratch1 ]]; then + # We are on NOAA Hera + MACHINE_ID=hera +elif [[ -d /work ]]; then + # We are on MSU Orion or Hercules + if [[ -d /apps/other ]]; then + # We are on Hercules + MACHINE_ID=hercules + else + MACHINE_ID=orion + fi +elif [[ -d /gpfs && -d /ncrc ]]; then + # We are on GAEA. + MACHINE_ID=gaea +elif [[ -d /data/prod ]]; then + # We are on SSEC's S4 + MACHINE_ID=s4 +else + echo WARNING: UNKNOWN PLATFORM 1>&2 fi diff --git a/ush/sub_discover b/ush/sub_discover index 583ffbef86..5d6364be97 100755 --- a/ush/sub_discover +++ b/ush/sub_discover @@ -130,7 +130,7 @@ echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile echo "module use -a $modulefiles" >> $cfile -echo "module load gsi_discover" >> $cfile +echo "module load gsi_discover.intel" >> $cfile echo "" >>$cfile echo "jobname=$jobname" >>$cfile echo "" >>$cfile diff --git a/ush/sub_gaea b/ush/sub_gaea index 6fed1b3c10..afad6aa7ab 100755 --- a/ush/sub_gaea +++ b/ush/sub_gaea @@ -129,7 +129,7 @@ echo "" >>$cfile echo "source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_gaea" >> $cfile +echo "module load gsi_gaea.intel" >> $cfile echo "module list" >> $cfile echo "" >>$cfile diff --git a/ush/sub_hercules b/ush/sub_hercules index 573378fdb6..e854d5727b 100755 --- a/ush/sub_hercules +++ b/ush/sub_hercules @@ -129,7 +129,7 @@ echo "" >>$cfile echo ". /apps/other/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_hercules" >> $cfile +echo "module load gsi_hercules.intel" >> $cfile echo "module list" >> $cfile echo "" >> $cfile cat $exec >> $cfile diff --git a/ush/sub_jet b/ush/sub_jet index d30c566ce3..9bd60486f6 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -127,7 +127,7 @@ echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_jet" >> $cfile +echo "module load gsi_jet.intel" >> $cfile echo "module list" >> $cfile echo "" >>$cfile diff --git a/ush/sub_orion b/ush/sub_orion index e5844474db..5a13f54845 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -129,7 +129,7 @@ echo "" >>$cfile echo ". /apps/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_orion" >> $cfile +echo "module load gsi_orion.intel" >> $cfile echo "module list" >> $cfile echo "" >> $cfile cat $exec >> $cfile diff --git a/ush/sub_wcoss2 b/ush/sub_wcoss2 index f2df099f23..cd21e932f8 100755 --- a/ush/sub_wcoss2 +++ b/ush/sub_wcoss2 @@ -125,7 +125,7 @@ echo "" >> $cfile echo "module reset" >> $cfile echo "module use $modulefiles" >> $cfile -echo "module load gsi_wcoss2" >> $cfile +echo "module load gsi_wcoss2.intel" >> $cfile echo "module load envvar/1.0" >> $cfile echo "module load cray-pals/1.2.2" >> $cfile echo "module -t list 2>&1 | while read line;do module show $line 2>&1 | sed -n -e '2p';done | sort" >> $cfile From 94c6a7c2e917f5edb08d899845711427258f9733 Mon Sep 17 00:00:00 2001 From: Clara Draper <33430543+ClaraDraper-NOAA@users.noreply.github.com> Date: Wed, 7 Feb 2024 10:26:19 -0700 Subject: [PATCH 02/35] Updates for soil moisture and soil temperature analysis (#675) Co-authored-by: jswhit2 Co-authored-by: guoqing.ge --- src/enkf/gridinfo_gfs.f90 | 1 + src/enkf/gridio_gfs.f90 | 53 +++++++++++++++++++++------------------ src/enkf/inflation.f90 | 34 ++++++++++++++++++++++--- src/enkf/readconvobs.f90 | 1 - src/enkf/statevec.f90 | 4 +-- src/gsi/read_prepbufr.f90 | 19 +++++++------- src/gsi/setupq.f90 | 2 +- src/gsi/setupt.f90 | 5 +--- 8 files changed, 75 insertions(+), 44 deletions(-) diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index 317ca2221c..de71153c69 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -67,6 +67,7 @@ module gridinfo character(len=max_varname_length),public, dimension(13) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'oz ', 'cw ', 'tsen', 'prse', & 'ql ', 'qi ', 'qr ', 'qs ', 'qg '/) character(len=max_varname_length),public, dimension(13) :: vars2d_supported = (/'ps ', 'pst', 'sst', 't2m', 'q2m', 'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /) +character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'st1', 'st2', 'st3', 'st4', 'sl1', 'sl2', 'sl3', 'sl4' /) ! supported variable names in anavinfo contains diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index e4631f4e2d..8afb012fcf 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -926,6 +926,7 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, endif ! use_full_hydro enddo else if (use_gfs_ncio) then + clip=tiny_r_kind call read_vardata(dset, 'ugrd', ug3d,errcode=iret) if (iret /= 0) then print *,'error reading ugrd' @@ -1203,36 +1204,36 @@ subroutine readgriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne)) endif if (slc1_ind > 0) then - call read_vardata(dset_sfc, 'slc1', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc1' + print *,'error reading soill1' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne)) endif if (slc2_ind > 0) then - call read_vardata(dset_sfc, 'slc2', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc2' + print *,'error reading soill2' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne)) endif if (slc3_ind > 0) then - call read_vardata(dset_sfc, 'slc3', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc3' + print *,'error reading soill3' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne)) endif if (slc4_ind > 0) then - call read_vardata(dset_sfc, 'slc4', values_2d, errcode=iret) + call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret) if (iret /= 0) then - print *,'error reading slc2' + print *,'error reading soill4' call stop2(22) endif ug = reshape(values_2d,(/nlons*nlats/)) @@ -2122,6 +2123,7 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n character(nemsio_charkind) :: field character(len=nf90_max_name) :: time_units logical :: hasfield + character(len=max_varname_length), dimension(n3d) :: no_vars3d real(r_kind) kap,kapr,kap1,clip real(r_single) compress_err @@ -2143,10 +2145,12 @@ subroutine writegriddata(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin,n call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) - if (write_sfc_file .and. nproc==0 ) then + if (write_sfc_file ) then ! adding the sfc increments requires adjusting several other variables. This is done is a separate ! program. - write(6,*)'gridio/writegriddata: not coded to write sfc analysis, use separate add_incr program instead' + if (nproc == 0) write(6,*)'gridio/writegriddata: not coded to write sfc analysis, will write increment for sfc fields' + no_vars3d='' + call writeincrement(nanal1,nanal2,no_vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) endif nocompress = .true. @@ -3584,7 +3588,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind ! netcdf things - integer(i_kind) :: dimids3(3), ncstart(3), nccount(3) + integer(i_kind) :: dimids3(3), ncstart(3), nccount(3), dimids2(2) integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & @@ -3615,7 +3619,6 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) - if ( write_atm_file) then use_full_hydro = .false. clip = tiny_r_kind read(datestring,*) iadateout @@ -3623,6 +3626,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ncstart = (/1, 1, 1/) nccount = (/nlons, nlats, nlevs/) + if ( write_atm_file) then ne = 0 ensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -3978,20 +3982,21 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! create dimensions based on analysis resolution, not guess call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid)) call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid)) + dimids2 = (/ lon_dimid, lat_dimid /) ! create variables call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real, (/lon_dimid/), lonvarid)) call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real, (/lat_dimid/), latvarid)) - call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids3(1:2), tmp2mvarid)) - call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids3(1:2), spfh2mvarid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids3(1:2), soilt1varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids3(1:2), soilt2varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids3(1:2), soilt3varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids3(1:2), soilt4varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids3(1:2), slc1varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids3(1:2), slc2varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids3(1:2), slc3varid)) - call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids3(1:2), slc4varid)) - call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids3(1:2), maskvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids2, tmp2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids2, spfh2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids2, soilt1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids2, soilt2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids2, soilt3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids2, soilt4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids2, slc1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids2, slc2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids2, slc3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids2, slc4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int, dimids2, maskvarid)) ! place global attributes to serial calc_increment output call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & @@ -4036,7 +4041,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! note: same logic/threshold used in global_cycle to produce ! mask on model grid. - call read_vardata(dsfg, 'slc1', values_2d, errcode=iret) + call read_vardata(dsfg, 'soill1', values_2d, errcode=iret) mask = 0 do j=1,nlats diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90 index 225967028c..51d1dd1106 100644 --- a/src/enkf/inflation.f90 +++ b/src/enkf/inflation.f90 @@ -77,7 +77,8 @@ module inflation use constants, only: one, zero, rad2deg, deg2rad use covlocal, only: latval, taper use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels -use gridinfo, only: latsgrd, logp, npts, nlevs_pres +! note: vars2d_landonly currently only defined for gridio_gfs, but smoothing only coded for gfs. +use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly use loadbal, only: indxproc, numptsperproc, npts_max, anal_chunk, anal_chunk_prior use smooth_mod, only: smooth @@ -101,9 +102,10 @@ subroutine inflate_ens() real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, & sumcoslattot,suma2tot,sumftot real(r_single) fnanalsml,coslat -integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind +integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind +integer(i_kind), dimension(8) :: soil_index character(len=500) filename -real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal +real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal,store_presmooth real(r_single) r fnanalsml = one/(real(nanals-1,r_single)) @@ -231,7 +233,33 @@ subroutine inflate_ens() do nn=1,ncdim call mpi_allreduce(mpi_in_place,covinfglobal(1,nn),npts,mpi_real4,mpi_sum,mpi_comm_world,ierr) enddo + ! do not apply smoothing to soil temp. or soil moisture (not globally defined) + + ind = 0 + do i = 1,8 + this_ind = getindex(cvars2d, vars2d_landonly(i)) + if (this_ind>0) then + ind=ind+1 + soil_index(ind)=this_ind + endif + enddo + + if (ind>0) then + allocate(store_presmooth(npts,ind)) + do i = 1, ind + store_presmooth(:,i) = covinfglobal(:,clevels(nc3d)+soil_index(i)) + enddo + endif + call smooth(covinfglobal) + + if (ind>0) then + do i = 1, ind + covinfglobal(:,clevels(nc3d) + soil_index(i)) = store_presmooth(:,i) + enddo + deallocate(store_presmooth) + endif + where (covinfglobal < covinflatemin) covinfglobal = covinflatemin where (covinfglobal > covinflatemax) covinfglobal = covinflatemax do i=1,numptsperproc(nproc+1) diff --git a/src/enkf/readconvobs.f90 b/src/enkf/readconvobs.f90 index a5383069a1..65db770b6d 100644 --- a/src/enkf/readconvobs.f90 +++ b/src/enkf/readconvobs.f90 @@ -24,7 +24,6 @@ module readconvobs ! reflectivity and radial velocity assimilation. POC: xuguang.wang@ou.edu ! 2017-12-13 shlyaeva - added netcdf diag read/write capability ! 2019-03-21 CAPS(C. Tong) - added direct reflectivity DA capability -! 2022-03-23 draper - added option to not scale qobs by forecast qsat. ! ! attributes: ! language: f95 diff --git a/src/enkf/statevec.f90 b/src/enkf/statevec.f90 index 5ad70346aa..44ad5df9b4 100644 --- a/src/enkf/statevec.f90 +++ b/src/enkf/statevec.f90 @@ -136,7 +136,7 @@ subroutine init_statevec() do i = 1, ns2d if (getindex(vars2d_supported, svars2d(i))<0) then if (nproc .eq. 0) then - print *,'Error: 2D variable ', svars2d(i), ' is not supported in current version.' + print *,'Error: state 2D variable ', svars2d(i), ' is not supported in current version.' print *,'Supported variables: ', vars2d_supported endif call stop2(502) @@ -145,7 +145,7 @@ subroutine init_statevec() do i = 1, ns3d if (getindex(vars3d_supported, svars3d(i))<0) then if (nproc .eq. 0) then - print *,'Error: 3D variable ', svars3d(i), ' is not supported in current version.' + print *,'Error: state 3D variable ', svars3d(i), ' is not supported in current version.' print *,'Supported variables: ', vars3d_supported endif call stop2(502) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 87d5aa4bd8..526dc9ee78 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -1669,13 +1669,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& pmq(k)=nint(qcmark(8,k)) end do -! 181, 183, 187, and 188 are the screen-level obs over land - global_2m_land = ( (kx==181 .or. kx==183 .or. kx==188 .or. kx==188 ) .and. hofx_2m_sfcfile ) +! 187, 181, and 183 are the screen-level obs over land +! note: don't need the hofx_2m_sfcfile if set usage in convinfo, and qm updated in the input file + global_2m_land = ( (kx==187 .or. kx==181 .or. kx==183) .and. hofx_2m_sfcfile ) ! If temperature ob, extract information regarding virtual ! versus sensible temperature if(tob) then ! use tvirtual if tsensible flag not set, and not in either 2Dregional or global_2m DA mode + ! for now, keeping 2m obs as sensible, for global system. if ( (.not. tsensible) .and. .not. (twodvar_regional .or. global_2m_land) ) then do k=1,levs @@ -1979,18 +1981,17 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& pqm(k)=2 ! otherwise, type 183 will be discarded. qm=2 tqm(k)=2 - if (kx==187) obserr(3,k)=2.2 - if (kx==181) obserr(3,k)=1.5 - if (kx==183) obserr(3,k)=2.6 + if (kx==187) obserr(3,k)=2.0_r_double + if (kx==181) obserr(3,k)=2.0_r_double + if (kx==183) obserr(3,k)=2.0_r_double endif if (qob .and. qm == 9 ) then qm = 2 ! qob err specified as fraction of qsat, multiplied by 10. - if (kx==187) obserr(2,k)=1.0 - if (kx==181) obserr(2,k)=1.0 - if (kx==183) obserr(2,k)=1.0 + if (kx==187) obserr(2,k)=1.0_r_double + if (kx==181) obserr(2,k)=1.0_r_double + if (kx==183) obserr(2,k)=1.0_r_double endif - endif ! Set usage variable usage = zero diff --git a/src/gsi/setupq.f90 b/src/gsi/setupq.f90 index ad6d727ce9..993d57046a 100644 --- a/src/gsi/setupq.f90 +++ b/src/gsi/setupq.f90 @@ -376,7 +376,7 @@ subroutine setupq(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav do k=1,nobs ikx=nint(data(ikxx,k)) itype=ictype(ikx) - landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) do l=k+1,nobs if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & diff --git a/src/gsi/setupt.f90 b/src/gsi/setupt.f90 index 8d1c308d7f..2f1f57f583 100644 --- a/src/gsi/setupt.f90 +++ b/src/gsi/setupt.f90 @@ -448,7 +448,7 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav do k=1,nobs ikx=nint(data(ikxx,k)) itype=ictype(ikx) - landsfctype =( itype==181 .or. itype==183 .or. itype==187 .or. itype==188 ) + landsfctype =( itype==181 .or. itype==183 .or. itype==187 ) do l=k+1,nobs if (twodvar_regional .or. (hofx_2m_sfcfile .and. landsfctype) ) then duplogic=data(ilat,k) == data(ilat,l) .and. & @@ -483,9 +483,6 @@ subroutine setupt(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav ! Run a buddy-check ! Note: buddy check crashes for hofx_2m_sfcfile option. -! Ccurrent params have buddy radius of 108 km, max diff of 8 K. -! The gross error check removes O-F > 7., so this is probably removing -! most obs that fail the buddy check already if (twodvar_regional .and. buddycheck_t) call buddy_check_t(is,data,luse,mype,nele,nobs,muse,buddyuse) ! If requested, save select data for output to diagnostic file From 291568517c8ff8ef6f0979377207ba555b104085 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Thu, 8 Feb 2024 11:31:11 -0500 Subject: [PATCH 03/35] =?UTF-8?q?a=20quick=20fix=20for=20Issue:A=20indexin?= =?UTF-8?q?g=20out=20of=20bounds=20issue=20shown=20in=20the=20global=5F4de?= =?UTF-8?q?nvar=20regr=E2=80=A6=20(#681)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In response to Issue:" A indexing out of bounds issue shown in the global_4denvar regression test in setuprad.f90 #676" (https://github.com/NOAA-EMC/GSI/issues/676) and following both online and off-line discussions, it is decided to retain the abi2km part in setuprad.f90 ( for potential future development/improvement), while a simple index-related checks are added to prevent the indexing error when GSI is built with debug mode. It is important to note that this indexing error does not impact GSI results (when GSI is built with optimization options) since abi2km is currently hardwire consfigured to be not used. Fixes #676 **DUE DATE for merger of this PR into `develop` is 2/22/2024 (six weeks after PR creation).** --------- Co-authored-by: Russ-Treadon-NOAA --- src/gsi/setuprad.f90 | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index 935366650c..ad8ccbc4e6 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -376,7 +376,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& logical in_curbin, in_anybin, save_jacobian logical account_for_corr_obs logical,dimension(nobs):: zero_irjaco3_pole - logical abi2km ! use 2km abi data (not CSR/ASR) ! Declare local arrays @@ -410,7 +409,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& real(r_kind) :: clw_guess,clw_guess_retrieval,ciw_guess,rain_guess,snow_guess,clw_avg real(r_kind),dimension(:), allocatable :: rsqrtinv real(r_kind),dimension(:), allocatable :: rinvdiag - real(r_kind),dimension(nchanl) :: abi2km_bc !for GMI (dual scan angles) real(r_kind),dimension(nchanl):: emissivity2,ts2, emissivity_k2,tsim2 @@ -529,7 +527,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& atms = obstype == 'atms' saphir = obstype == 'saphir' abi = obstype == 'abi' - abi2km = .false. ssmis=ssmis_las.or.ssmis_uas.or.ssmis_img.or.ssmis_env.or.ssmis @@ -1102,13 +1099,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero - if (abi2km .and. regional) then - abi2km_bc = zero - abi2km_bc(2) = 233.5_r_kind - abi2km_bc(3) = 241.7_r_kind - abi2km_bc(4) = 250.5_r_kind - end if - !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) @@ -1187,17 +1177,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do end if - if (abi2km .and. regional) then - pred(:,i) = zero - if (i>=2 .and. i<=4) then - if (tb_obs(i) > 190.0_r_kind .and. tb_obs(i) < 300.0_r_kind) then - pred(1,i)=1.0_r_kind - pred(2,i)=tb_obs(i)-abi2km_bc(i) - pred(3,i)=(tb_obs(i)-abi2km_bc(i))**2 - pred(4,i)=(tb_obs(i)-abi2km_bc(i))**3 - end if - end if - end if do j = 1,npred predbias(j,i) = predchan(j,i)*pred(j,i) From bae0342fc9f30d40364d371460b8422adf10dee7 Mon Sep 17 00:00:00 2001 From: Xiaoyan Zhang <45010998+xyzemc@users.noreply.github.com> Date: Fri, 9 Feb 2024 14:13:45 -0500 Subject: [PATCH 04/35] =?UTF-8?q?Fix=20=20soil=20temperature/mositure=20re?= =?UTF-8?q?ad=20=20from=20RRFS=20warm-start=20r=E2=80=A6=20(#683)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit **DUE DATE for merger of this PR into `develop` is 2/27/2024 (six weeks after PR creation).** **Description** - Undefined soil_temp and soil_moist for regional because they are not correctly read in from the RRFS' warm-sart restart file as described in the issue#677. - Undefined or zero value of soil temp and moist will affect the calculation of surface emissivity. Surface emissivity is a factor to calculate the microwave surface channel radiance. Resolves #677 **Fix** In gsi_rfv3io_mod.f90, replace 'STC' with 'tslb', replace 'SMC' as 'smois **How has this need tested?** - This has been tested on Hera. The values of soil_temp and soil_moisture have been verified are correct now from the RRFS restart file. --- src/gsi/gsi_rfv3io_mod.f90 | 55 +++++++++++++++++++++++++++----------- 1 file changed, 39 insertions(+), 16 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 7f0f00ac84..51c32eb7aa 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -25,6 +25,7 @@ module gsi_rfv3io_mod ! 2022-08-10 Wang - add IO for regional FV3-SMOKE (RRFS-SMOKE) model ! 2023-07-30 Zhao - add IO for the analysis of the significant wave height ! (SWH, aka howv in GSI) in fv3-lam based DA (eg., RRFS-3DRTMA) +! 2024-01-24 X.Zhang - bug fix for reading the soil temp and mois from the wram start file ! ! subroutines included: ! sub gsi_rfv3io_get_grid_specs @@ -2048,6 +2049,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) integer(i_kind),allocatable :: gfile_loc_layout(:) character(len=180) :: filename_layout +! for sfc 2d vaiable exist or not + logical, dimension(n2d) :: sfc_var_exist + sfcdata= fv3filenamegin%sfcdata dynvars= fv3filenamegin%dynvars @@ -2059,6 +2063,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) !-- initialisation of the array for howv sfcn2d(:,:,k_howv) = zero +!-- initialisation of the array for sfc_var_exist + sfc_var_exist = .false. + if(mype==mype_2d ) then allocate(sfc_fulldomain(nx,ny)) @@ -2109,30 +2116,43 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) iret=nf90_inquire_variable(gfile_loc,i,name,len) if( trim(name)=='f10m'.or.trim(name)=='F10M' ) then k=k_f10m + sfc_var_exist(k) = .true. else if( trim(name)=='stype'.or.trim(name)=='STYPE' ) then k=k_stype + sfc_var_exist(k) = .true. else if( trim(name)=='vfrac'.or.trim(name)=='VFRAC' ) then k=k_vfrac + sfc_var_exist(k) = .true. else if( trim(name)=='vtype'.or.trim(name)=='VTYPE' ) then k=k_vtype + sfc_var_exist(k) = .true. else if( trim(name)=='zorl'.or.trim(name)=='ZORL' ) then k=k_zorl + sfc_var_exist(k) = .true. else if( trim(name)=='tsea'.or.trim(name)=='TSEA' ) then k=k_tsea + sfc_var_exist(k) = .true. else if( trim(name)=='sheleg'.or.trim(name)=='SHELEG' ) then k=k_snwdph - else if( trim(name)=='stc'.or.trim(name)=='STC' ) then + sfc_var_exist(k) = .true. + else if( trim(name)=='stc'.or.trim(name)=='tslb' ) then k=k_stc - else if( trim(name)=='smc'.or.trim(name)=='SMC' ) then + sfc_var_exist(k) = .true. + else if( trim(name)=='smc'.or.trim(name)=='smois' ) then k=k_smc + sfc_var_exist(k) = .true. else if( trim(name)=='SLMSK'.or.trim(name)=='slmsk' ) then k=k_slmsk + sfc_var_exist(k) = .true. else if( trim(name)=='T2M'.or.trim(name)=='t2m' ) then k=k_t2m + sfc_var_exist(k) = .true. else if( trim(name)=='Q2M'.or.trim(name)=='q2m' ) then k=k_q2m + sfc_var_exist(k) = .true. else if( trim(name)=='HOWV'.or.trim(name)=='howv' ) then k=k_howv + sfc_var_exist(k) = .true. else cycle endif @@ -2268,29 +2288,32 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) !-- broadcast the updated i_howv_3dda to all tasks (!!!!) call mpi_bcast(i_howv_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) +!-- broadcast the updated sfc_var_exist to all tasks (!!!!) + call mpi_bcast(sfc_var_exist, n2d, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) + !!!!!!! scatter !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! call mpi_scatterv(work,ijns2d,displss2d,mpi_rtype,& sfcn2d,ijns2d(mm1),mpi_rtype,mype_2d,mpi_comm_world,ierror) deallocate ( work ) - fact10(:,:,it)=sfcn2d(:,:,k_f10m) - soil_type(:,:,it)=sfcn2d(:,:,k_stype) - veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac) - veg_type(:,:,it)=sfcn2d(:,:,k_vtype) - sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl) - sfct(:,:,it)=sfcn2d(:,:,k_tsea) - sno(:,:,it)=sfcn2d(:,:,k_snwdph) - soil_temp(:,:,it)=sfcn2d(:,:,k_stc) - soil_moi(:,:,it)=sfcn2d(:,:,k_smc) - ges_z(:,:)=sfcn2d(:,:,k_orog)/grav - isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk)) + if ( sfc_var_exist(k_f10m) ) fact10(:,:,it)=sfcn2d(:,:,k_f10m) + if ( sfc_var_exist(k_stype) ) soil_type(:,:,it)=sfcn2d(:,:,k_stype) + if ( sfc_var_exist(k_vfrac) ) veg_frac(:,:,it)=sfcn2d(:,:,k_vfrac) + if ( sfc_var_exist(k_vtype) ) veg_type(:,:,it)=sfcn2d(:,:,k_vtype) + if ( sfc_var_exist(k_zorl) ) sfc_rough(:,:,it)=sfcn2d(:,:,k_zorl) + if ( sfc_var_exist(k_tsea) ) sfct(:,:,it)=sfcn2d(:,:,k_tsea) + if ( sfc_var_exist(k_snwdph)) sno(:,:,it)=sfcn2d(:,:,k_snwdph) + if ( sfc_var_exist(k_stc) ) soil_temp(:,:,it)=sfcn2d(:,:,k_stc) + if ( sfc_var_exist(k_smc) ) soil_moi(:,:,it)=sfcn2d(:,:,k_smc) + if ( sfc_var_exist(k_orog) ) ges_z(:,:)=sfcn2d(:,:,k_orog)/grav + if ( sfc_var_exist(k_slmsk) ) isli(:,:,it)=nint(sfcn2d(:,:,k_slmsk)) if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then - ges_t2m(:,:)=sfcn2d(:,:,k_t2m) - ges_q2m(:,:)=sfcn2d(:,:,k_q2m) + if ( sfc_var_exist(k_t2m) ) ges_t2m(:,:)=sfcn2d(:,:,k_t2m) + if ( sfc_var_exist(k_q2m) ) ges_q2m(:,:)=sfcn2d(:,:,k_q2m) endif if ( i_howv_3dda == 1 ) then - ges_howv(:,:)=sfcn2d(:,:,k_howv) + if ( sfc_var_exist(k_howv) ) ges_howv(:,:)=sfcn2d(:,:,k_howv) endif deallocate (sfcn2d,a) return From cd620030dc33c45381daceaa82e0b598a404076f Mon Sep 17 00:00:00 2001 From: Gang Zhao <53267411+GangZhao-NOAA@users.noreply.github.com> Date: Tue, 13 Feb 2024 14:06:33 -0500 Subject: [PATCH 05/35] Adding the dry-bulb air temperature and tv flag in the observation diagnostic file of conventional Q obs (for 3D RTMA run only) (#688) - Motivation: In the Auto-QC utility of 3D-RTMA, the dry-bulb air temperature (hereafter as T_dry) which is accompanied with moisture observation is required in the procedure of the quality control for conventional moisture observations (Q obs). Since this auto-qc of 3DRTMA retrieves many information from the observation diagnostic files (output of GSI run), it should be convenient for the sake of auto-qc of Q obs, if the required T_dry could be output into the observation diagnostics file of Q obs in the GSI run. - Modifications to the code: **_read_prepbufr.f90_**: for qob and rtma run, add lines to use tpc to identify the sensible temp and virtual temp, and mark with tvflag, then get tdry with the temp obs in different ways w.r.t the associated tvflag; **_setupq.f90_**: add line to use l_rtma3d from module rapidrefresh_cldsurf_mod variable nreal (the length of obs diag information record for each obs) needs to be increased by 2 (for tdry and tvflag, when running GSI for 3DRTMA only) in subroutine contents_binary_diag_, add line to put tdry into the array rdiagbuff (for binary format obsdaig file) in subroutine contents_netcdf_diag_, add line to put tdry into metadata (for netcdf format obsdiag file) This PR is to address the issue #666 : Adding the (calculated) dry-bulb temperature in the observation diagnostic file for conventional Q obs (only for 3D RTMA) --- src/gsi/read_prepbufr.f90 | 46 ++++++++++++++++++++++++++++++++++++--- src/gsi/setupq.f90 | 25 +++++++++++++++++++++ 2 files changed, 68 insertions(+), 3 deletions(-) diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index 526dc9ee78..f281573a4e 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -149,8 +149,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! 2020-05-04 wu - no rotate_wind for fv3_regional ! 2020-09-05 CAPS(C. Tong) - add flag for new vadwind obs to assimilate around the analysis time only ! 2023-03-23 draper - add code for processing T2m and q2m for global system -! 2023-07-30 Zhao - added code to extract obs of significant wave height (howvob) from bufr record +! 2023-07-30 zhao - added code to extract obs of significant wave height (howvob) from bufr record ! in prepbufr file for 3D analysis +! 2024-01-11 zhao - added code to extract sensible temp (tdry) and tv flag +! for moisture obs(qob) when running (2D/3D)RTMA ! input argument list: ! infile - unit from which to read BUFR data @@ -225,6 +227,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use adjust_cloudobs_mod, only: adjust_convcldobs,adjust_goescldobs use mpimod, only: npe use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean + use rapidrefresh_cldsurf_mod, only: l_rtma3d use gsi_io, only: verbose use phil2, only: denest ! hilbert curve @@ -390,6 +393,10 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& logical, allocatable,dimension(:) :: rusage,rthin ! end of block +! for extracting sensible-vs-virtual temp obs + integer(i_kind),dimension(1,255):: tqm4q + real(r_kind),dimension(1,255):: tvflg4q + real(r_double),dimension(1,255):: tobs4q ! equivalence to handle character names equivalence(r_prvstg(1,1),c_prvstg) @@ -876,6 +883,9 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& glcd=-999._r_double endif + if(print_verbose) write(6,'(1x,A,A,A,2(A,1x,F8.3))') 'read_prepbufr:', & + trim(adjustl(obstype)),':', ' vtcd= ',vtcd,' glcd= ',glcd + call init_rjlists call init_aircraft_rjlists if(i_gsdsfc_uselist==1) call init_gsd_sfcuselist @@ -1503,6 +1513,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if(driftl)call ufbint(lunin,drfdat,8,255,iret,drift) ! raob level enhancement on temp and q obs +! (note: levs is increased by sonde_ext, and not same as original value read from prepbufr) if(ext_sonde .and. kx==120) call sonde_ext(obsdat,tpc,qcmark,obserr,drfdat,levs,kx,vtcd) nread=nread+levs @@ -1713,6 +1724,25 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if end if +! If moisture ob (qob) and (2D/3D)RTMA, set tv flag information (based on tpc) +! regarding virtual vs. sensible temperaure, to get tdry (if virtual temp +! then compute tdry; if sensible temp, then tdry= tsen), then save tdry +! in q-obsdaig file for RTMA offline Auto-QC. + if (qob .and. (l_rtma3d .or. twodvar_regional)) then + tobs4q(1,:) = bmiss + tqm4q(1,:) = bmiss + tvflg4q(1,:)= -one + do k=1,levs + tvflg4q(1,k)=one ! initialize as sensible + tobs4q(1,k)=obsdat(3,k) ! temp obs read in prepbufr + tqm4q(1,k)=tqm(k) + do j=1,20 + if (tpc(k,j)==vtcd) tvflg4q(1,k)=zero ! reset flag if virtual + if (tpc(k,j)>=bmiss) exit ! end of stack + end do + end do + end if ! if qob & rtma + if(i_gsdqc==2) then ! AMV acceptance for all obs (E. James) if (kx >= 240 .and. kx <= 260) then @@ -2398,7 +2428,15 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& end if qobcon=obsdat(2,k)*convert tdry=r999 - if (tqm(k) Date: Tue, 13 Feb 2024 14:29:45 -0500 Subject: [PATCH 06/35] update fix submodule for GFS v16.3.12 and soil analysis changes (#695) --- fix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fix b/fix index 5722cd4d25..298bdc0f56 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 5722cd4d2519222137c5b356bdbc01bb34c5f1f4 +Subproject commit 298bdc0f56692ad25141a946177e5d88884e367a From 74ac5942118d2a83ca84d3a629ec3aaffdb36fc5 Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Wed, 14 Feb 2024 18:07:15 +0000 Subject: [PATCH 07/35] Upgrade the GSI to Spack-Stack version 1.6.0 (#684) --- ci/spack.yaml | 12 +- modulefiles/gsi_cheyenne.gnu.lua | 32 ------ modulefiles/gsi_cheyenne.intel.lua | 32 ------ modulefiles/gsi_common.lua | 6 +- modulefiles/gsi_hera.gnu.lua | 8 +- modulefiles/gsi_hera.intel.lua | 6 +- modulefiles/gsi_hercules.intel.lua | 6 +- modulefiles/gsi_jet.intel.lua | 6 +- modulefiles/gsi_orion.intel.lua | 6 +- modulefiles/gsi_s4.intel.lua | 6 +- modulefiles/gsi_wcoss2.intel.lua | 2 +- regression/regression_param.sh | 32 ------ regression/regression_var.sh | 18 +-- ush/module-setup.sh | 7 -- ush/sub_cheyenne | 169 ----------------------------- ush/sub_hercules | 4 +- 16 files changed, 32 insertions(+), 320 deletions(-) delete mode 100644 modulefiles/gsi_cheyenne.gnu.lua delete mode 100644 modulefiles/gsi_cheyenne.intel.lua delete mode 100644 ush/sub_cheyenne diff --git a/ci/spack.yaml b/ci/spack.yaml index deacdff0b5..647904108e 100644 --- a/ci/spack.yaml +++ b/ci/spack.yaml @@ -7,19 +7,19 @@ spack: - gcc@10:10 specs: - netcdf-c@4.9.2 - - netcdf-fortran@4.6.0 + - netcdf-fortran@4.6.1 - bufr@11.7.0 - bacio@2.4.1 - - w3emc@2.9.2 - - sp@2.3.3 - - ip@3.3.3 + - w3emc@2.10.0 + - sp@2.5.0 + - ip@4.3.0 - sigio@2.3.2 - sfcio@1.4.1 - nemsio@2.5.4 - wrf-io@1.2.0 - ncio@1.1.2 - - crtm@2.4.0 - - gsi-ncdiag@1.1.1 + - crtm@2.4.0.1 + - gsi-ncdiag@1.1.2 view: true concretizer: unify: true diff --git a/modulefiles/gsi_cheyenne.gnu.lua b/modulefiles/gsi_cheyenne.gnu.lua deleted file mode 100644 index 1d903082a8..0000000000 --- a/modulefiles/gsi_cheyenne.gnu.lua +++ /dev/null @@ -1,32 +0,0 @@ -help([[ -]]) - - -unload("ncarenv/1.3") -unload("intel/19.1.1") -unload("ncarcompilers/0.5.0") -unload("mpt/2.25") -unload("netcdf/4.8.1") - -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") -prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") - -local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" -local stack_gnu_ver=os.getenv("stack_gnu_ver") or "10.1.0" -local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.1" -local cmake_ver=os.getenv("cmake_ver") or "3.22.0" - -load(pathJoin("stack-gcc", stack_gnu_ver)) -load(pathJoin("stack-openmpi", stack_openmpi_ver)) -load(pathJoin("stack-python", stack_python_ver)) -load(pathJoin("cmake", cmake_ver)) -load(pathJoin("prod_util", os.getenv("prod_util_ver") or "1.2.2")) -load(pathJoin("openblas", os.getenv("openblas_ver") or "0.3.23")) - -load("gsi_common") - -pushenv("CFLAGS", "-xHOST") -pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") - -whatis("Description: GSI environment on Cheyenne with GNU Compilers") diff --git a/modulefiles/gsi_cheyenne.intel.lua b/modulefiles/gsi_cheyenne.intel.lua deleted file mode 100644 index 8c328e2b34..0000000000 --- a/modulefiles/gsi_cheyenne.intel.lua +++ /dev/null @@ -1,32 +0,0 @@ -help([[ -]]) - -unload("ncarenv/1.3") -unload("intel/19.1.1") -unload("ncarcompilers/0.5.0") -unload("mpt/2.25") -unload("netcdf/4.8.1") - -prepend_path("MODULEPATH", "/glade/work/epicufsrt/contrib/spack-stack/cheyenne/spack-stack-1.4.1/envs/unified-env/install/modulefiles/Core") -prepend_path("MODULEPATH", "/glade/work/jedipara/cheyenne/spack-stack/modulefiles/misc") - -local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" -local stack_intel_ver=os.getenv("stack_intel_ver") or "19.1.1.217" -local stack_mpi_ver=os.getenv("stack_mpi_ver") or "2019.7.217" -local cmake_ver=os.getenv("cmake_ver") or "3.22.0" - -load(pathJoin("stack-intel", stack_intel_ver)) -load(pathJoin("stack-intel-mpi", stack_mpi_ver)) -load(pathJoin("stack-python", stack_python_ver)) -load(pathJoin("cmake", cmake_ver)) - -load("gsi_common") -load(pathJoin("prod-util", os.getenv("prod_util_ver") or "1.2.2")) -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230911") - -pushenv("CFLAGS", "-xHOST") -pushenv("FFLAGS", "-xHOST") - -pushenv("GSI_BINARY_SOURCE_DIR", "/glade/work/epicufsrt/contrib/GSI_data/fix/20230601") - -whatis("Description: GSI environment on Cheyenne with Intel Compilers") diff --git a/modulefiles/gsi_common.lua b/modulefiles/gsi_common.lua index d3365a98dc..cb49a43878 100644 --- a/modulefiles/gsi_common.lua +++ b/modulefiles/gsi_common.lua @@ -3,19 +3,19 @@ Load common modules to build GSI on all machines ]]) local netcdf_c_ver=os.getenv("netcdf_c_ver") or "4.9.2" -local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.0" +local netcdf_fortran_ver=os.getenv("netcdf_fortran_ver") or "4.6.1" local bufr_ver=os.getenv("bufr_ver") or "11.7.0" local bacio_ver=os.getenv("bacio_ver") or "2.4.1" local w3emc_ver=os.getenv("w3emc_ver") or "2.10.0" -local sp_ver=os.getenv("sp_ver") or "2.3.3" +local sp_ver=os.getenv("sp_ver") or "2.5.0" local ip_ver=os.getenv("ip_ver") or "4.3.0" local sigio_ver=os.getenv("sigio_ver") or "2.3.2" local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" -local crtm_ver=os.getenv("crtm_ver") or "2.4.0" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1" local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.2" load(pathJoin("netcdf-c", netcdf_c_ver)) diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index 550b01ee7b..d85e79b005 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -1,16 +1,16 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") --Needed for openmpi build prepend_path("MODULEPATH", "/scratch1/NCEPDEV/jcsda/jedipara/spack-stack/modulefiles") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_gnu_ver=os.getenv("stack_gnu_ver") or "9.2.0" local stack_openmpi_ver=os.getenv("stack_openmpi_ver") or "4.1.5" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -local openblas_ver=os.getenv("openblas_ver") or "0.3.19" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" +local openblas_ver=os.getenv("openblas_ver") or "0.3.24" load(pathJoin("stack-gcc", stack_gnu_ver)) load(pathJoin("stack-openmpi", stack_openmpi_ver)) diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index abdc6e5623..b967c32f74 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua index bf29bc21db..c72323cbad 100644 --- a/modulefiles/gsi_hercules.intel.lua +++ b/modulefiles/gsi_hercules.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/hercules/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") -local stack_python_ver=os.getenv("stack_python_ver") or "3.10.8" +local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua index 20b80ff61a..b2b98be7ff 100644 --- a/modulefiles/gsi_jet.intel.lua +++ b/modulefiles/gsi_jet.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index 80ec342c93..114e5f8ad1 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") -local stack_python_ver=os.getenv("python_ver") or "3.10.8" +local stack_python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_s4.intel.lua b/modulefiles/gsi_s4.intel.lua index a60ea3c16e..08e3d38516 100644 --- a/modulefiles/gsi_s4.intel.lua +++ b/modulefiles/gsi_s4.intel.lua @@ -1,13 +1,13 @@ help([[ ]]) -prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.5.1/envs/gsi-addon/install/modulefiles/Core") +prepend_path("MODULEPATH", "/data/prod/jedi/spack-stack/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") -local python_ver=os.getenv("python_ver") or "3.10.8" +local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.0" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) diff --git a/modulefiles/gsi_wcoss2.intel.lua b/modulefiles/gsi_wcoss2.intel.lua index 8dde986e58..28b2f0d09d 100644 --- a/modulefiles/gsi_wcoss2.intel.lua +++ b/modulefiles/gsi_wcoss2.intel.lua @@ -20,7 +20,7 @@ local sfcio_ver=os.getenv("sfcio_ver") or "1.4.1" local nemsio_ver=os.getenv("nemsio_ver") or "2.5.4" local wrf_io_ver=os.getenv("wrf_io_ver") or "1.2.0" local ncio_ver=os.getenv("ncio_ver") or "1.1.2" -local crtm_ver=os.getenv("crtm_ver") or "2.4.0" +local crtm_ver=os.getenv("crtm_ver") or "2.4.0.1" local ncdiag_ver=os.getenv("ncdiag_ver") or "1.1.1" load(pathJoin("PrgEnv-intel", PrgEnv_intel_ver)) diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 46d2647ac0..2ac615fc4a 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -36,11 +36,6 @@ case $machine in ;; Discover) sub_cmd="sub_discover" - ;; - Cheyenne) - sub_cmd="sub_cheyenne" - memnode=128 - numcore=36 ;; *) # EXIT out for unresolved machine echo "unknown $machine" @@ -73,9 +68,6 @@ case $regtest in elif [[ "$machine" = "Discover" ]]; then topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" @@ -106,9 +98,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -139,9 +128,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -171,9 +157,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -204,9 +187,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" @@ -237,9 +217,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" @@ -270,9 +247,6 @@ case $regtest in elif [[ "$machine" = "Jet" ]]; then topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" - elif [[ "$machine" = "Cheyenne" ]]; then - topts[1]="0:15:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" @@ -342,12 +316,6 @@ elif [[ "$machine" = "Gaea" ]]; then export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 export APRUN="srun --export=ALL --mpi=pmi2 -n \$ntasks" -elif [[ "$machine" = "Cheyenne" ]]; then - export OMP_STACKSIZE=1024M - export MPI_BUFS_PER_PROC=256 - export MPI_BUFS_PER_HOST=256 - export MPI_GROUP_MAX=256 - export APRUN="mpirun -v -np \$ntasks" elif [[ "$machine" = "wcoss2" ]]; then export OMP_PLACES=cores export OMP_STACKSIZE=2G diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 02ffb24b12..9d91b2c41f 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -30,9 +30,7 @@ else fi # Determine the machine -if [[ -d /glade ]]; then # Cheyenne - export machine="Cheyenne" -elif [[ -d /scratch1 ]]; then # Hera +if [[ -d /scratch1 ]]; then # Hera export machine="Hera" elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet export machine="Jet" @@ -66,20 +64,6 @@ case $machine in export check_resource="no" export accnt="nggps_emc" ;; - Cheyenne) - export queue="regular" - export noscrub="/glade/scratch/$LOGNAME/noscrub" - export group="global" - if [[ "$cmaketest" = "false" ]]; then - export basedir="/glade/scratch/$LOGNAME" - fi - export ptmp="/glade/scratch/$LOGNAME/$ptmpName" - - export casesdir="/glade/work/epicufsrt/contrib/GSI_data/CASES/regtest" - - export check_resource="no" - export accnt="NRAL0032" - ;; wcoss2) export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}" if [ -d $local_or_default ]; then diff --git a/ush/module-setup.sh b/ush/module-setup.sh index d13da1efa3..c1893ab4ee 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -40,13 +40,6 @@ elif [[ $MACHINE_ID = wcoss2 ]]; then # We are on WCOSS2 module reset -elif [[ $MACHINE_ID = cheyenne* ]] ; then - # We are on NCAR Cheyenne - if ( ! eval module help > /dev/null 2>&1 ) ; then - source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh - fi - module purge - elif [[ $MACHINE_ID = stampede* ]] ; then # We are on TACC Stampede if ( ! eval module help > /dev/null 2>&1 ) ; then diff --git a/ush/sub_cheyenne b/ush/sub_cheyenne deleted file mode 100644 index 7389bfeb24..0000000000 --- a/ush/sub_cheyenne +++ /dev/null @@ -1,169 +0,0 @@ -#!/bin/sh --login -set -x -echo "starting sub_cheyenne" -usage="\ -Usage: $0 [options] executable [args] - where the options are: - -a account account (default: none) - -b binding run smt binding or not (default:NO) - -d dirin initial directory (default: cwd) - -e envars copy comma-separated environment variables - -g group group name - -i append standard input to command file - -j jobname specify jobname (default: executable basename) - -m machine machine on which to run (default: current) - -n write command file to stdout rather than submitting it - -o output specify output file (default: jobname.out) - -p procs[/nodes[/ppreq] - number of MPI tasks and optional nodes or Bblocking and - ppreq option (N or S) (defaults: serial, Bunlimited, S) - -q queue[/qpreq] queue name and optional requirement, e.g. dev/P - (defaults: 1 if serial or dev if parallel and none) - (queue 3 or 4 is dev or prod with twice tasks over ip) - (options: P=parallel, B=bigmem, b=batch) - -r rmem[/rcpu] resources memory and cpus/task (default: '1024 mb', 1) - -t timew wall time limit in [[hh:]mm:]ss format (default: 900) - -u userid userid to run under (default: self) - -v verbose mode - -w when when to run, in yyyymmddhh[mm], +hh[mm], thh[mm], or - Thh[mm] (full, incremental, today or tomorrow) format - (default: now) -Function: This command submits a job to the batch queue." -subcmd="$*" -stdin=NO -nosub=NO -account="" -binding="NO" -dirin="" -envars="" -group="" -jobname="" -machine="" -output="" -procs=0 -nodes="" -ppreq="" -queue="" -qpreq="" -rmem="1024" -rcpu="1" -timew="900" -userid="" -verbose=NO -when="" -while getopts a:b:d:e:g:ij:m:no:p:q:r:t:u:vw: opt;do - case $opt in - a) account="$OPTARG";; - b) binding="$OPTARG";; - d) dirin="$OPTARG";; - e) envars="$OPTARG";; - g) group="$OPTARG";; - i) stdin=YES;; - j) jobname=$OPTARG;; - m) machine="$OPTARG";; - n) nosub=YES;; - o) output=$OPTARG;; - p) procs=$(echo $OPTARG/|cut -d/ -f1);nodes=$(echo $OPTARG/|cut -d/ -f2);ppreq=$(echo $OPTARG/|cut -d/ -f3);; - q) queue=$(echo $OPTARG/|cut -d/ -f1);qpreq=$(echo $OPTARG/|cut -d/ -f2);; - r) rmem=$(echo $OPTARG/|cut -d/ -f1);rcpu=$(echo $OPTARG/|cut -d/ -f2);; - t) timew=$OPTARG;; - u) userid=$OPTARG;; - v) verbose=YES;; - w) when=$OPTARG;; - \?) echo $0: invalid option >&2;echo "$usage" >&2;exit 1;; - esac -done -shift $(($OPTIND-1)) -if [[ $# -eq 0 ]];then - echo $0: missing executable name >&2;echo "$usage" >&2;exit 1 -fi -exec=$1 -if [[ ! -s $exec ]]&&which $exec >/dev/null 2>&1;then - exec=$(which $exec) -fi -shift -args="$*" -bn=$(basename $exec) -export jobname=${jobname:-$bn} -output=${output:-$jobname.out} -myuser=$LOGNAME -myhost=$(hostname) - -DATA=/glade/scratch/$LOGNAME/tmp -mkdir -p $DATA - -timew=${timew:-01:20:00} -task_node=${task_node:-$procs} -size=$((nodes*task_node)) -envars=$envars -threads=${rcpu:-1} - -export TZ=GMT -cfile=$DATA/sub$$ -> $cfile -echo "#!/bin/sh --login" >> $cfile -echo "" >> $cfile -echo "#PBS -o $output" >> $cfile -echo "#PBS -N $jobname" >> $cfile -echo "#PBS -q $queue" >> $cfile -echo "#PBS -l walltime=$timew" >> $cfile -echo "#PBS -l select=$nodes:ncpus=$procs:mpiprocs=$procs" >> $cfile -echo "#PBS -j oe" >> $cfile -echo "#PBS -A $accnt" >> $cfile -echo "#PBS -V" >> $cfile - -echo "" >>$cfile -echo "export ntasks=$(( $nodes * $procs ))" >> $cfile -echo "export ppn=$procs" >> $cfile -echo "export threads=$threads" >> $cfile -echo "export OMP_NUM_THREADS=$threads" >> $cfile -echo "ulimit -s unlimited" >> $cfile -echo "" >>$cfile -echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile -echo "" >>$cfile - -echo "cfile = $cfile" -echo "source /glade/u/apps/ch/modulefiles/default/localinit/localinit.sh >> $cfile" -echo "module purge" >> $cfile -echo "module use $modulefiles" >> $cfile -echo "module load gsi_cheyenne.intel" >> $cfile -echo "module list" >> $cfile - -cat $exec >> $cfile - -if [[ $nosub = YES ]];then - cat $cfile - exit -elif [[ $verbose = YES ]];then - set -x - cat $cfile -fi - - -if [[ $stdin = YES ]];then - cat -fi >>$cfile -if [[ $nosub = YES ]];then - cat $cfile - exit -elif [[ $verbose = YES ]];then - set -x - cat $cfile -fi -qsub=${qsub:-qsub} - -ofile=$DATA/subout$$ ->$ofile -chmod 777 $ofile -$qsub $cfile >$ofile -rc=$? -cat $ofile -if [[ -w $SUBLOG ]];then - jobn=$(grep -i submitted $ofile|head -n1|cut -d\" -f2) - date -u +"%Y%m%d%H%M%S : $subcmd : $jobn" >>$SUBLOG -fi -rm $cfile $ofile -[[ $MKDATA = YES ]] && rmdir $DATA -echo "ending sub_cheyenne" -exit $rc - diff --git a/ush/sub_hercules b/ush/sub_hercules index e854d5727b..459b480559 100755 --- a/ush/sub_hercules +++ b/ush/sub_hercules @@ -119,7 +119,6 @@ echo "export ntasks=$(( $nodes * $procs ))" >> $cfile echo "export ppn=$procs" >> $cfile echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile -##echo "export OMP_STACKSIZE=2048M" >> $cfile echo "ulimit -s unlimited" >> $cfile echo "" >>$cfile @@ -130,7 +129,8 @@ echo ". /apps/other/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile echo "module load gsi_hercules.intel" >> $cfile -echo "module list" >> $cfile +#TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Hercules +echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile echo "" >> $cfile cat $exec >> $cfile From 7c4a57188ce33752e3be8721012cc5686ae56e17 Mon Sep 17 00:00:00 2001 From: Ming Hu Date: Fri, 23 Feb 2024 09:30:50 -0700 Subject: [PATCH 08/35] Fix three bugs found in RRFS test (#705) **DUE DATE for merger of this PR into `develop` is 4/2/2024 (six weeks after PR creation).** **Description** We found three bugs in RRFS test: 1) add "vars2d_landonly" to regional gridinfo files for compiling. 2) add terrain to "sfc_var_exist" check 3) fix case selection bug for FED GSI DA. Resolves #704 Resolves #702 Resolves #703 **Type of change** Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** Those fixes are tested with full RRFS cases and with several cycles of RRFS retro. **Checklist** - [x ] My code follows the style guidelines of this project - [x ] I have performed a self-review of my own code - [x ] I have commented my code, particularly in hard-to-understand areas - [ ] New and existing tests pass with my changes - [ ] Any dependent changes have been merged and published --- src/enkf/gridinfo_fv3reg.f90 | 2 ++ src/enkf/gridinfo_nmmb.f90 | 2 ++ src/enkf/gridinfo_wrf.f90 | 2 ++ src/gsi/cplr_get_fv3_regional_ensperts.f90 | 2 +- src/gsi/gsi_rfv3io_mod.f90 | 1 + 5 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index 4eff63c003..9a16f0ca03 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -79,6 +79,8 @@ module gridinfo character(len=max_varname_length),public, dimension(3) :: & vars2d_supported = [character(len=max_varname_length) :: & 'ps', 'pst', 'sst'] +character(len=max_varname_length),public, dimension(8) :: & + vars2d_landonly = (/'', '', '', '', '', '', '', '' /) real(r_single), allocatable, dimension(:) :: ak,bk,eta1_ll,eta2_ll integer (i_kind),public,allocatable,dimension(:,:):: nxlocgroup,nylocgroup integer(i_kind):: numproc_io_sub diff --git a/src/enkf/gridinfo_nmmb.f90 b/src/enkf/gridinfo_nmmb.f90 index d60b077f36..df6c22ee1e 100644 --- a/src/enkf/gridinfo_nmmb.f90 +++ b/src/enkf/gridinfo_nmmb.f90 @@ -25,6 +25,8 @@ module gridinfo 'cw', 'prse', 'ql', 'qr', 'qi', & 'qli', 'dbz', 'w'/) character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps', 'sst' /) +character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'', '', '', '', '', '', '', '' /) + contains subroutine getgridinfo(fileprefix, reducedgrid) diff --git a/src/enkf/gridinfo_wrf.f90 b/src/enkf/gridinfo_wrf.f90 index f4f68a64c4..e67b827b41 100644 --- a/src/enkf/gridinfo_wrf.f90 +++ b/src/enkf/gridinfo_wrf.f90 @@ -77,6 +77,8 @@ module gridinfo ! supported variable names in anavinfo character(len=max_varname_length),public, dimension(19) :: vars3d_supported = (/'u ', 'v ', 'tv ', 'q ', 'w ', 'cw ', 'ph ', 'ql ', 'qr ', 'qs ', 'qg ', 'qi ', 'qni ', 'qnr ', 'qnc ', 'dbz ', 'oz ', 'tsen', 'prse' /) character(len=max_varname_length),public, dimension(2) :: vars2d_supported = (/ 'ps ', 'sst' /) + character(len=max_varname_length),public, dimension(8) :: vars2d_landonly = (/'', '', '', '', '', '', '', '' /) + contains diff --git a/src/gsi/cplr_get_fv3_regional_ensperts.f90 b/src/gsi/cplr_get_fv3_regional_ensperts.f90 index 512560f278..9b841f012c 100644 --- a/src/gsi/cplr_get_fv3_regional_ensperts.f90 +++ b/src/gsi/cplr_get_fv3_regional_ensperts.f90 @@ -430,7 +430,7 @@ subroutine get_fv3_regional_ensperts_run(this,en_perts,nelen,ps_bar) if(.not.l_use_dbz_directDA .and. if_model_dbz .and. .not.if_model_fed) i_caseflag=2 ! only if_model_fed is true - if(.not.l_use_dbz_directDA .and. .not.if_model_dbz .and. .not.if_model_fed) i_caseflag=3 + if(.not.l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=3 ! l_use_dbz_directDA=.true. and if_model_fed=.true. if(l_use_dbz_directDA .and. .not.if_model_dbz .and. if_model_fed) i_caseflag=4 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 51c32eb7aa..b3f3488a70 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -2239,6 +2239,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) do k=ndimensions+1,nvariables iret=nf90_inquire_variable(gfile_loc,k,name,len) if(trim(name)=='PHIS' .or. trim(name)=='phis' ) then + sfc_var_exist(k_orog) = .true. iret=nf90_inquire_variable(gfile_loc,k,ndims=ndim) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 From fca6bea4e5c737efe53fd053ca9cc69033f847f7 Mon Sep 17 00:00:00 2001 From: James Jung Date: Tue, 27 Feb 2024 13:08:05 -0500 Subject: [PATCH 09/35] CrIS viirs bug fix (#708) --- src/gsi/read_cris.f90 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/gsi/read_cris.f90 b/src/gsi/read_cris.f90 index b8bf4ff92b..d5668f8864 100644 --- a/src/gsi/read_cris.f90 +++ b/src/gsi/read_cris.f90 @@ -334,14 +334,18 @@ subroutine read_cris(mype,val_cris,ithin,isfcalc,rmesh,jsatid,gstime,& spc_filename = trim(crtm_coeffs_path)//'viirs-m_n20.SpcCoeff.bin' sensorlist_imager = 'viirs-m_n20' inquire(file=trim(spc_filename), exist=imager_coeff) - if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin' - sensorlist_imager = 'viirs-m_j1' + if ( .not. imager_coeff ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_j1.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j1' + endif elseif ( trim(jsatid) == 'n21' ) then spc_filename = trim(crtm_coeffs_path)//'viirs-m_n21.SpcCoeff.bin' sensorlist_imager = 'viirs-m_n21' inquire(file=trim(spc_filename), exist=imager_coeff) - if ( .not. imager_coeff ) spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin' - sensorlist_imager = 'viirs-m_j2' + if ( .not. imager_coeff ) then + spc_filename = trim(crtm_coeffs_path)//'viirs-m_j2.SpcCoeff.bin' + sensorlist_imager = 'viirs-m_j2' + endif endif inquire(file=trim(spc_filename), exist=imager_coeff) if ( imager_coeff ) then From f282a9447e9d3c37e7866a7c9cebb96c0bb5068b Mon Sep 17 00:00:00 2001 From: xincjin-NOAA <122945910+xincjin-NOAA@users.noreply.github.com> Date: Tue, 12 Mar 2024 14:02:12 -0400 Subject: [PATCH 10/35] Assimilate GMI in GSI (#692) --- regression/global_4denvar.sh | 55 +++++----- regression/global_enkf.sh | 19 ++-- regression/regression_namelists.sh | 2 +- regression/regression_var.sh | 2 +- src/gsi/clw_mod.f90 | 2 +- src/gsi/deter_sfc_mod.f90 | 138 +++++++++----------------- src/gsi/radiance_mod.f90 | 6 +- src/gsi/read_gmi.f90 | 6 +- src/gsi/setuprad.f90 | 13 +-- src/gsi/ssmis_spatial_average_mod.f90 | 29 ++---- 10 files changed, 106 insertions(+), 166 deletions(-) diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 08a62f5eb0..056815228b 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -55,14 +55,15 @@ cycg=`echo $gdate | cut -c9-10` dumpobs=gdas prefix_obs=${dumpobs}.t${cyca}z prefix_ges=gdas.t${cycg}z -prefix_ens=gdas.t${cycg}z +prefix_ens=enkfgdas.t${cycg}z suffix=tm00.bufr_d dumpges=gdas COMROOTgfs=$casesdir/gfs/prod -datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/atmos -datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos -datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos +datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/obs +dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model_data/atmos/history +datanl=$COMROOTgfs/gdas.$PDYg/${cycg}/analysis/atmos +datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg} # Set up $tmpdir @@ -265,28 +266,28 @@ $nln $datobs/${prefix_obs}.esatms.${suffix} ./atmsbufrears ## $nln $datobs/${prefix_obs}.amsr2.tm00.bufr_d ./amsr2bufr # Copy bias correction, atmospheric and surface files -$nln $datges/${prefix_ges}.abias ./satbias_in -$nln $datges/${prefix_ges}.abias_pc ./satbias_pc -$nln $datges/${prefix_ges}.abias_air ./aircftbias_in -$nln $datges/${prefix_ges}.radstat ./radstat.gdas - -$nln $datges/${prefix_ges}.sfcf003.nc ./sfcf03 -$nln $datges/${prefix_ges}.sfcf004.nc ./sfcf04 -$nln $datges/${prefix_ges}.sfcf005.nc ./sfcf05 -$nln $datges/${prefix_ges}.sfcf006.nc ./sfcf06 -$nln $datges/${prefix_ges}.sfcf007.nc ./sfcf07 -$nln $datges/${prefix_ges}.sfcf008.nc ./sfcf08 -$nln $datges/${prefix_ges}.sfcf009.nc ./sfcf09 - -$nln $datges/${prefix_ges}.atmf003.nc ./sigf03 -$nln $datges/${prefix_ges}.atmf004.nc ./sigf04 -$nln $datges/${prefix_ges}.atmf005.nc ./sigf05 -$nln $datges/${prefix_ges}.atmf006.nc ./sigf06 -$nln $datges/${prefix_ges}.atmf007.nc ./sigf07 -$nln $datges/${prefix_ges}.atmf008.nc ./sigf08 -$nln $datges/${prefix_ges}.atmf009.nc ./sigf09 - -$nln $datens/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid +$nln $datanl/${prefix_ges}.abias ./satbias_in +$nln $datanl/${prefix_ges}.abias_pc ./satbias_pc +$nln $datanl/${prefix_ges}.abias_air ./aircftbias_in +$nln $datanl/${prefix_ges}.radstat ./radstat.gdas + +$nln $dathis/${prefix_ges}.sfcf003.nc ./sfcf03 +$nln $dathis/${prefix_ges}.sfcf004.nc ./sfcf04 +$nln $dathis/${prefix_ges}.sfcf005.nc ./sfcf05 +$nln $dathis/${prefix_ges}.sfcf006.nc ./sfcf06 +$nln $dathis/${prefix_ges}.sfcf007.nc ./sfcf07 +$nln $dathis/${prefix_ges}.sfcf008.nc ./sfcf08 +$nln $dathis/${prefix_ges}.sfcf009.nc ./sfcf09 + +$nln $dathis/${prefix_ges}.atmf003.nc ./sigf03 +$nln $dathis/${prefix_ges}.atmf004.nc ./sigf04 +$nln $dathis/${prefix_ges}.atmf005.nc ./sigf05 +$nln $dathis/${prefix_ges}.atmf006.nc ./sigf06 +$nln $dathis/${prefix_ges}.atmf007.nc ./sigf07 +$nln $dathis/${prefix_ges}.atmf008.nc ./sigf08 +$nln $dathis/${prefix_ges}.atmf009.nc ./sigf09 + +$nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid export ENS_PATH='./ensemble_data/' mkdir -p ${ENS_PATH} @@ -296,7 +297,7 @@ for fh in $flist; do imem=1 while [[ $imem -le $NMEM_ENKF ]]; do member="mem"`printf %03i $imem` - $nln $datens/$member/$sigens ${ENS_PATH}sigf${fh}_ens_${member} + $nln $datens/$member/model_data/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member} (( imem = $imem + 1 )) done done diff --git a/regression/global_enkf.sh b/regression/global_enkf.sh index e458c5830d..ca40abda52 100755 --- a/regression/global_enkf.sh +++ b/regression/global_enkf.sh @@ -51,17 +51,14 @@ cyca=`echo $global_adate | cut -c9-10` PDYg=`echo $gdate | cut -c1-8` cycg=`echo $gdate | cut -c9-10` -dumpobs=gdas -prefix_obs=${dumpobs}.t${cyca}z -prefix_ges=gdas.t${cycg}z -prefix_ens=gdas.t${cycg}z +prefix_obs=enkfgdas.t${cyca}z +prefix_ens=enkfgdas.t${cycg}z suffix=tm00.bufr_d dumpges=gdas COMROOTgfs=$casesdir/gfs/prod -datobs=$COMROOTgfs/enkfgdas.$PDYa/${cyca}/atmos -datges=$COMROOTgfs/$dumpges.$PDYg/${cycg}/atmos -datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg}/atmos +datobs=$COMROOTgfs/enkfgdas.$PDYa/${cyca}/ensstat/analysis/atmos +datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg} # Set up $tmpdir @@ -166,19 +163,19 @@ nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'` for fhr in $nfhrs; do for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) - $nln $datens/$memchar/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} if [ $cnvw_option = ".true." ]; then - $nln $datens/$memchar/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} fi (( imem = $imem + 1 )) done - $nln $datens/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean + $nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean if [ $cnvw_option = ".true." ]; then $nln $datens/${prefix_ens}.sfcf00${fhr}.ensmean.nc sfgsfc_${global_adate}_fhr0${fhr}_ensmean fi done -$nln $datobs/${prefix_obs}.abias_int ./satbias_in +$nln $datobs/${prefix_obs}.abias_int.ensmean ./satbias_in cd $tmpdir diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 552bc1ba59..7ca183ef3e 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -181,7 +181,7 @@ OBS_INPUT:: sstviirs viirs-m j1 viirs-m_j1 0.0 4 0 abibufr abi g18 abi_g18 0.0 1 0 ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 1 + atmsbufr atms n21 atms_n21 0.0 1 0 crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 9d91b2c41f..315028675c 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -190,7 +190,7 @@ export savdir="$ptmp" export JCAP="62" # Case Study analysis dates -export global_adate="2022110900" +export global_adate="2024022300" export rtma_adate="2020022420" export fv3_netcdf_adate="2017030100" export rrfs_3denvar_glbens_adate="2021072518" diff --git a/src/gsi/clw_mod.f90 b/src/gsi/clw_mod.f90 index 512aaded01..49387f05eb 100644 --- a/src/gsi/clw_mod.f90 +++ b/src/gsi/clw_mod.f90 @@ -2019,7 +2019,7 @@ subroutine gmi_37pol_diff(tb37v,tb37h,tsim37v,tsim37h,clw,ierrret) clw = one - (tb37v-tb37h)/(tsim37v-tsim37h) clw=max(zero,clw) - if(tb37h > tb37v) then + if ((tb37h > tb37v) .or. (tb37h > 500_r_kind )) then ierrret = 1 clw= r1000 endif diff --git a/src/gsi/deter_sfc_mod.f90 b/src/gsi/deter_sfc_mod.f90 index 300d36cffb..271e81c5d2 100644 --- a/src/gsi/deter_sfc_mod.f90 +++ b/src/gsi/deter_sfc_mod.f90 @@ -33,7 +33,7 @@ module deter_sfc_mod use satthin, only: sno_full,isli_full,sst_full,soil_moi_full, & soil_temp_full,soil_type_full,veg_frac_full,veg_type_full, & fact10_full,zs_full,sfc_rough_full,zs_full_gfs - use constants, only: zero,one,two,one_tenth,deg2rad,rad2deg + use constants, only: zero,one,two,one_tenth,deg2rad,rad2deg, rearth use gridmod, only: nlat,nlon,regional,tll2xy,nlat_sfc,nlon_sfc,rlats_sfc,rlons_sfc, & rlats,rlons,dx_gfs,txy2ll,lpl_gfs use guess_grids, only: nfldsfc,hrdifsfc,ntguessfc @@ -1331,7 +1331,7 @@ subroutine deter_sfc_amsre_low(dlat_earth,dlon_earth,isflg,sfcpct) end subroutine deter_sfc_amsre_low -subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) +subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg) !$$$ subprogram documentation block ! . . . . ! subprogram: deter_sfc_gmi determine land surface type @@ -1354,11 +1354,6 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) ! 2 sea ice ! 3 snow ! 4 mixed -! sfcpct(0:3)- percentage of 4 surface types -! (0) - sea percentage -! (1) - land percentage -! (2) - sea ice percentage -! (3) - snow percentage ! ! attributes: ! language: f90 @@ -1370,15 +1365,11 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) real(r_kind) ,intent(in ) :: dlat_earth,dlon_earth integer(i_kind) ,intent( out) :: isflg - real(r_kind),dimension(0:3),intent( out) :: sfcpct - - integer(i_kind) jsli,it - integer(i_kind):: klat1,klon1,klatp1,klonp1 - real(r_kind):: dx,dy,dx1,dy1,w00,w10,w01,w11 - real(r_kind) :: dlat,dlon + integer(i_kind) jsli,it, i, j + integer(i_kind):: klat1,klon1,klatp1,klonp1, ksmall, klarge, n_grid + real(r_kind) :: dlat,dlon, grid_dist + integer(i_kind):: klatn,klonn,klatpn,klonpn logical :: outside - integer(i_kind):: klat2,klon2,klatp2,klonp2 - ! ! For interpolation, we usually use o points (4points for land sea decision) ! In case of lowfreq channel (Large FOV), add the check of x points(8 points) @@ -1407,90 +1398,55 @@ subroutine deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) end if klon1=int(dlon); klat1=int(dlat) - dx =dlon-klon1; dy =dlat-klat1 - dx1 =one-dx; dy1 =one-dy - w00=dx1*dy1; w10=dx1*dy; w01=dx*dy1; w11=dx*dy klat1=min(max(1,klat1),nlat_sfc); klon1=min(max(0,klon1),nlon_sfc) if(klon1==0) klon1=nlon_sfc klatp1=min(nlat_sfc,klat1+1); klonp1=klon1+1 - if(klonp1==nlon_sfc+1) klonp1=1 - klonp2 = klonp1+1 - if(klonp2==nlon_sfc+1) klonp2=1 - klon2=klon1-1 - if(klon2==0)klon2=nlon_sfc - klat2=max(1,klat1-1) - klatp2=min(nlat_sfc,klatp1+1) ! Set surface type flag. Begin by assuming obs over ice-free water - sfcpct = zero - - jsli = isli_full(klat1 ,klon1 ) - if(sno_full(klat1 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klon1 ) - if(sno_full(klatp1 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat1 ,klonp1) - if(sno_full(klat1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klonp1) - if(sno_full(klatp1 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp2,klon1) - if(sno_full(klatp2 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp2,klonp1) - if(sno_full(klatp2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klon2) - if(sno_full(klatp1 ,klon2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klatp1,klonp2) - if(sno_full(klatp1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat1,klon2) - if(sno_full(klat1 ,klon2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat1,klonp2) - if(sno_full(klat1 ,klonp2 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat2,klon1) - if(sno_full(klat2 ,klon1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - jsli = isli_full(klat2,klonp1) - if(sno_full(klat2 ,klonp1 ,it) > one .and. jsli == 1)jsli=3 - sfcpct(jsli)=sfcpct(jsli)+one - - sfcpct=sfcpct/12.0_r_kind - -! sfcpct(3)=min(sfcpct(3),sfcpct(1)) -! sfcpct(1)=max(zero,sfcpct(1)-sfcpct(3)) - - if(sfcpct(0) > 0.99_r_kind)then - isflg = 0 - else if(sfcpct(1) > 0.99_r_kind)then - isflg = 1 - else if(sfcpct(2) > 0.99_r_kind)then - isflg = 2 - else if(sfcpct(3) > 0.99_r_kind)then - isflg = 3 - else - isflg = 4 - end if + grid_dist=rearth * (rlats_sfc(klatp1) - rlats_sfc(klat1)) + n_grid=int(40000 / grid_dist) + 1 + klatn = max(klat1 - n_grid, 1) + klonn = klon1 - n_grid + if (klonn < 0) klonn = nlon_sfc - klonn + klatpn = min((klat1 + n_grid), nlat_sfc) + klonpn = klon1 + n_grid + if (klonpn > nlon_sfc) klonpn = klonpn - nlon_sfc + + isflg=0 + outer: do i = klatn, klatpn + ! assume n_grid > 2 + if (0 < klonpn - klonn .and. klonpn - klonn < nlon_sfc / 2) then + do j = klonn, klonpn + if (isli_full(i, j) /= 0) then + isflg = 1 + exit outer + end if + end do + else + if (klonpn < klonn) then + ksmall = klonpn + klarge = klonn + else + ksmall = klonn + klarge = klonpn + end if + do j = 1, ksmall + if (isli_full(i, j) /= 0) then + isflg = 1 + exit outer + endif + end do + do j = klarge, nlon_sfc + if (isli_full(i, j) /= 0) then + isflg = 1 + exit outer + end if + end do + end if + end do outer return end subroutine deter_sfc_gmi diff --git a/src/gsi/radiance_mod.f90 b/src/gsi/radiance_mod.f90 index 60aa0bc3cd..aae7794957 100644 --- a/src/gsi/radiance_mod.f90 +++ b/src/gsi/radiance_mod.f90 @@ -1326,11 +1326,7 @@ subroutine radiance_ex_biascor_gmi(radmod,clw_obs,clw_guess_retrieval,nchanl,cld do i=1,nchanl if (radmod%lcloud4crtm(i)<0) cycle - if (clw_obs <= cclr(i) .and. clw_guess_retrieval <= cclr(i) .and. abs(clw_obs-clw_guess_retrieval) < 0.001_r_kind) then - cld_rbc_idx(i)=one !clear/clear - else - cld_rbc_idx(i)=zero - endif + if ((clw_obs-cclr(i))*(clw_guess_retrieval-cclr(i))=0.005_r_kind) cld_rbc_idx(i)=zero end do return diff --git a/src/gsi/read_gmi.f90 b/src/gsi/read_gmi.f90 index f54263b129..6ad4d829a3 100644 --- a/src/gsi/read_gmi.f90 +++ b/src/gsi/read_gmi.f90 @@ -184,7 +184,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& integer(i_kind) :: jc,bufsat,n integer(i_kind),dimension(5):: iobsdate integer(i_kind):: method,iobs,num_obs - integer(i_kind),parameter :: maxobs=4000000 + integer(i_kind),parameter :: maxobs=6000000 !-- integer(i_kind),parameter :: nscan=74 ! after binning ifov, 221/3 + 1 integer(i_kind),parameter :: nscan=221 @@ -414,7 +414,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call ufbrep(lnbufr,var_check1,1,nchanl,iret,'GMICHQ') !call ufbrep(lnbufr,gmirfi,1,nchanl,iret,'GMIRFI') call ufbrep(lnbufr,pixelsaza,1,ngs,iret,'SAZA') - call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'SAMA SZA SMA SGA') + call ufbrep(lnbufr,val_angls,n_angls,ngs,iret,'BEARAZ SOZA SOLAZI SSGA') call ufbint(lnbufr,pixelloc,2, 1,iret,'CLATH CLONH') if (any(var_check1 < 99999999999_r_double)) then ! 100000000000 seems to be the missing value @@ -696,7 +696,7 @@ subroutine read_gmi(mype,val_gmi,ithin,rmesh,jsatid,gstime,& call deter_sfc(dlat,dlon,dlat_earth,dlon_earth,t4dv,isflg,idomsfc,sfcpct, & ts,tsavg,vty,vfr,sty,stp,sm,sn,zz,ff10,sfcr) - call deter_sfc_gmi(dlat_earth,dlon_earth,isflg,sfcpct) + call deter_sfc_gmi(dlat_earth,dlon_earth,isflg) ! Only keep obs over ocean - ej diff --git a/src/gsi/setuprad.f90 b/src/gsi/setuprad.f90 index ad8ccbc4e6..136568d1f3 100644 --- a/src/gsi/setuprad.f90 +++ b/src/gsi/setuprad.f90 @@ -1099,6 +1099,7 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& endif predbias=zero + !$omp parallel do schedule(dynamic,1) private(i,mm,j,k,tlap,node,bias) do i=1,nchanl mm=ich(i) @@ -1177,7 +1178,6 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& end do end if - do j = 1,npred predbias(j,i) = predchan(j,i)*pred(j,i) end do @@ -1263,8 +1263,8 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& if(amsua.or.atms) then call ret_amsua(tsim_bc,nchanl,tsavg5,zasat,clw_guess_retrieval,ierrret) else if(gmi) then - call gmi_37pol_diff(tsim_bc(6),tsim_bc(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_guess_retrieval,ierrret) - call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr_bc(6),tsim_clr_bc(7),clw_obs,ierrret) + call gmi_37pol_diff(tsim(6),tsim(7),tsim_clr(6),tsim_clr(7),clw_guess_retrieval,ierrret) + call gmi_37pol_diff(tb_obs(6),tb_obs(7),tsim_clr(6),tsim_clr(7),clw_obs,ierrret) end if if (radmod%ex_obserr=='ex_obserr1') then call radiance_ex_biascor(radmod,nchanl,tsim_bc,tsavg5,zasat, & @@ -1298,11 +1298,12 @@ subroutine setuprad(obsLL,odiagLL,lunin,mype,aivals,stats,nchanl,nreal,nobs,& do i=1,nchanl pred(6,i) = zero pred(7,i) = zero - clw_avg = half*(clw_obs+clw_guess_retrieval) +! Need to investigate clw_ave = half*(clw_obs+clw_guess_retrieval) + clw_avg = zero if (i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. & - abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one + abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = zero if (i < 5 .and. clw_obs > 0.2_r_kind .and. clw_guess_retrieval > 0.2_r_kind .and. & - abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = one + abs(clw_obs-clw_guess_retrieval) < 0.005_r_kind .and. clw_avg < 0.5_r_kind) cld_rbc_idx2(i) = zero if( i > 3 .and. clw_obs > 0.05_r_kind .and. clw_guess_retrieval > 0.05_r_kind .and. cld_rbc_idx(i) == zero) then pred(6,i) = clw_avg*clw_avg diff --git a/src/gsi/ssmis_spatial_average_mod.f90 b/src/gsi/ssmis_spatial_average_mod.f90 index 64dd5c6cf7..30b69c6223 100644 --- a/src/gsi/ssmis_spatial_average_mod.f90 +++ b/src/gsi/ssmis_spatial_average_mod.f90 @@ -682,26 +682,15 @@ SUBROUTINE SSMIS_Spatial_Average(BufrSat, Method, Num_Obs, NChanl, & ! Define grid box by channel - ! Ch 1-2: 1 scan direction, 1 track direction ! Ch 3-13: 3 scan direction, 3 track direction - if ((ic == 1) .or. (ic == 2)) then - ns1 = iscan - ns2 = iscan - if (ns1 < 1) ns1=1 - if (ns2 > max_scan) ns2=max_scan - np1 = ifov - np2 = ifov - if (np1 < 1) np1=1 - if (np2 > max_fov_gmi) np2=max_fov_gmi - else if ((ic > 2) .and. (ic < 14)) then - ns1 = iscan-1 - ns2 = iscan+1 - if (ns1 < 1) ns1=1 - if (ns2 > max_scan) ns2=max_scan - np1 = ifov-1 - np2 = ifov+1 - if (np1 < 1) np1=1 - if (np2 > max_fov_gmi) np2=max_fov_gmi - endif + ns1 = iscan-4 + ns2 = iscan+4 + if (ns1 < 1) ns1=1 + if (ns2 > max_scan) ns2=max_scan + np1 = ifov-8 + np2 = ifov+8 + if (np1 < 1) np1=1 + if (np2 > max_fov_gmi) np2=max_fov_gmi xnum = 0.0_r_kind mta = 0.0_r_kind if (any(bt_image_orig(np1:np2,ns1:ns2,ic) < btmin .or. & @@ -716,7 +705,7 @@ SUBROUTINE SSMIS_Spatial_Average(BufrSat, Method, Num_Obs, NChanl, & lat2 = latitude(ip,is) lon2 = longitude(ip,is) dist = distance(lat1,lon1,lat2,lon2) - if (dist > 50.0_r_kind) cycle gmi_box_x1 ! outside the box + if (dist > 20.0_r_kind) cycle gmi_box_x1 ! outside the box if (gaussian_wgt) then wgt = exp(-0.5_r_kind*(dist/sigma)*(dist/sigma)) else From a8d670c9f7096b2c7ac81801d6f2146b6c08bf4c Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Thu, 14 Mar 2024 11:55:05 -0400 Subject: [PATCH 11/35] Update fix submodule (Rcov_crisn21) & GSI_BINARY_SOURCE_DIR (#718) --- fix | 2 +- modulefiles/gsi_gaea.intel.lua | 2 +- modulefiles/gsi_hera.gnu.lua | 2 +- modulefiles/gsi_hera.intel.lua | 2 +- modulefiles/gsi_hercules.intel.lua | 2 +- modulefiles/gsi_jet.intel.lua | 2 +- modulefiles/gsi_orion.intel.lua | 2 +- modulefiles/gsi_s4.intel.lua | 2 +- modulefiles/gsi_wcoss2.intel.lua | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/fix b/fix index 298bdc0f56..92de100c4d 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 298bdc0f56692ad25141a946177e5d88884e367a +Subproject commit 92de100c4d5893e9d6409afbdda6937b0de1cb3b diff --git a/modulefiles/gsi_gaea.intel.lua b/modulefiles/gsi_gaea.intel.lua index ef6b9ddba7..96643202a7 100644 --- a/modulefiles/gsi_gaea.intel.lua +++ b/modulefiles/gsi_gaea.intel.lua @@ -31,7 +31,7 @@ local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/" prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64")) pushenv("MKLROOT", MKLROOT) -pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20240208") setenv("CC","cc") setenv("FC","ftn") diff --git a/modulefiles/gsi_hera.gnu.lua b/modulefiles/gsi_hera.gnu.lua index d85e79b005..eab352553f 100644 --- a/modulefiles/gsi_hera.gnu.lua +++ b/modulefiles/gsi_hera.gnu.lua @@ -22,6 +22,6 @@ load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) load(pathJoin("openblas", openblas_ver)) -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Hera with GNU Compilers") diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index b967c32f74..2d36f375e0 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/scratch1/NCEPDEV/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Hera with Intel Compilers") diff --git a/modulefiles/gsi_hercules.intel.lua b/modulefiles/gsi_hercules.intel.lua index c72323cbad..66ec9b03e1 100644 --- a/modulefiles/gsi_hercules.intel.lua +++ b/modulefiles/gsi_hercules.intel.lua @@ -21,6 +21,6 @@ load("intel-oneapi-mkl/2022.2.1") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Hercules with Intel Compilers") diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua index b2b98be7ff..cc43e98260 100644 --- a/modulefiles/gsi_jet.intel.lua +++ b/modulefiles/gsi_jet.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-axSSE4.2,AVX,CORE-AVX2") pushenv("FFLAGS", "-axSSE4.2,AVX,CORE-AVX2") -pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/mnt/lfs4/HFIP/hfv3gfs/glopara/git/fv3gfs/fix/gsi/20240208") whatis("Description: GSI environment on Jet with Intel Compilers") diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index 114e5f8ad1..03ea22018d 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") -pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/work/noaa/global/glopara/fix/gsi/20240208") whatis("Description: GSI environment on Orion with Intel Compilers") diff --git a/modulefiles/gsi_s4.intel.lua b/modulefiles/gsi_s4.intel.lua index 08e3d38516..04945eef3e 100644 --- a/modulefiles/gsi_s4.intel.lua +++ b/modulefiles/gsi_s4.intel.lua @@ -20,6 +20,6 @@ load(pathJoin("prod_util", prod_util_ver)) pushenv("CFLAGS", "-march=ivybridge") pushenv("FFLAGS", "-march=ivybridge") -pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/data/prod/glopara/fix/gsi/20240208") whatis("Description: GSI environment on S4 with Intel Compilers") diff --git a/modulefiles/gsi_wcoss2.intel.lua b/modulefiles/gsi_wcoss2.intel.lua index 28b2f0d09d..c3bfd1156c 100644 --- a/modulefiles/gsi_wcoss2.intel.lua +++ b/modulefiles/gsi_wcoss2.intel.lua @@ -46,6 +46,6 @@ load(pathJoin("ncio", ncio_ver)) load(pathJoin("crtm", crtm_ver)) load(pathJoin("ncdiag",ncdiag_ver)) -pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20230911") +pushenv("GSI_BINARY_SOURCE_DIR", "/lfs/h2/emc/global/noscrub/emc.global/FIX/fix/gsi/20240208") whatis("Description: GSI environment on WCOSS2") From 8d740a764d1b9d32e11cf1d0b4dd0ca26873871f Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 18 Mar 2024 15:26:36 -0400 Subject: [PATCH 12/35] Update read_ozone.f90 to handle GOME data before and after 20240131 18Z (#721) --- src/gsi/read_ozone.f90 | 61 +++++++++++++++++++++++++++++------------- 1 file changed, 42 insertions(+), 19 deletions(-) diff --git a/src/gsi/read_ozone.f90 b/src/gsi/read_ozone.f90 index 2ad95a858e..e6d3411d97 100644 --- a/src/gsi/read_ozone.f90 +++ b/src/gsi/read_ozone.f90 @@ -138,7 +138,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & character(8) subset,subset6,subset8,subset8_ompsnp character(49) ozstr,ozostr character(63) lozstr - character(51) ozgstr + character(51) ozgstr_v1,ozgstr_v2 character(27) ozgstr2 character(42) ozostr2 character(64) mlstr @@ -165,11 +165,12 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ! maximum number of observations set to real(r_kind),allocatable,dimension(:,:):: ozout - real(r_double) toq,poq + real(r_double) toq,poq,orbn real(r_double),dimension(nloz_v6):: ozone_v6 real(r_double),dimension(29,nloz_v8):: ozone_v8 real(r_double),dimension(10):: hdroz - real(r_double),dimension(10):: hdrozg + integer(i_kind):: nhdrozg + real(r_double),allocatable,dimension(:):: hdrozg real(r_double),dimension(5):: hdrozg2 real(r_double),dimension(10):: hdrozo real(r_double),dimension(8) :: hdrozo2 @@ -195,8 +196,10 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & data lozstr & / 'OSP12 OSP11 OSP10 OSP9 OSP8 OSP7 OSP6 OSP5 OSP4 OSP3 OSP2 OSP1 ' / - data ozgstr & - / 'SAID CLAT CLON YEAR DOYR HOUR MINU SECO SOZA SOLAZI' / + data ozgstr_v1 & + / 'SAID CLAT CLON SOZA SOLAZI YEAR DOYR HOUR MINU SECO' / + data ozgstr_v2 & + / 'SAID CLAT CLON SOZA SOLAZI YEAR MNTH DAYS HOUR MINU SECO' / data ozgstr2 & / 'CLDMNT SNOC ACIDX STKO FOVN' / data ozostr & @@ -482,8 +485,19 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & cycle obsloop endif -! extract header information - call ufbint(lunin,hdrozg,10,1,iret,ozgstr) +! Test for BUFR version using ORBN mnemonic + call ufbint(lunin,orbn,1,1,iret,'ORBN') + if (orbn > 100000000.0_r_kind) then + nhdrozg = 11 + else + nhdrozg = 10 + endif + if (.not.allocated(hdrozg)) allocate(hdrozg(nhdrozg)) + if (nhdrozg == 11) then + call ufbint(lunin,hdrozg,nhdrozg,1,iret,ozgstr_v2) + else + call ufbint(lunin,hdrozg,nhdrozg,1,iret,ozgstr_v1) + endif call ufbint(lunin,hdrozg2,5,1,iret,ozgstr2) rsat = hdrozg(1); ksatid=rsat @@ -494,7 +508,7 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & if (ksatid /= kidsat) cycle obsloop ! NESDIS does not put a flag for high SZA gome-2 data (SZA > 84 degree) - if ( hdrozg(9) > r84 ) cycle obsloop + if ( hdrozg(4) > r84 ) cycle obsloop nmrecs=nmrecs+nloz+1 @@ -520,15 +534,24 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & endif ! Convert observation time to relative time - idate5(1) = hdrozg(4) !year - IDAYYR = hdrozg(5) ! Day of year - JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 & - -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR - call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR) -! idate5(2) month -! idate5(3) day - idate5(4) = hdrozg(6) !hour - idate5(5) = hdrozg(7) !minute + if (nhdrozg == 11) then + idate5(1) = hdrozg(6) !year + idate5(2) = hdrozg(7) !month + idate5(3) = hdrozg(8) !day + idate5(4) = hdrozg(9) !hour + idate5(5) = hdrozg(10) !minute + else + idate5(1) = hdrozg(6) !year + IDAYYR = hdrozg(7) ! Day of year + JULIAN = -31739 + 1461 * (idate5(1) + 4799) /4 & + -3 * ((idate5(1) + 4899) / 100) / 4 + IDAYYR + call w3fs26(JULIAN,idate5(1),idate5(2),idate5(3),IDAYWK,IDAYYR) +! idate5(2) month +! idate5(3) day + idate5(4) = hdrozg(8) !hour + idate5(5) = hdrozg(9) !minute + endif + call w3fs21(idate5,nmind) t4dv=real((nmind-iwinbgn),r_kind)*r60inv sstime=real(nmind,r_kind) @@ -574,8 +597,8 @@ subroutine read_ozone(nread,ndata,nodata,jsatid,infile,gstime,lunout, & ozout(5,itx)=dlon_earth_deg ! earth relative longitude (degrees) ozout(6,itx)=dlat_earth_deg ! earth relative latitude (degrees) ozout(7,itx)=toq ! total ozone error flag - ozout(8,itx)=hdrozg(9) ! solar zenith angle - ozout(9,itx)=hdrozg(10) ! solar azimuth angle + ozout(8,itx)=hdrozg(4) ! solar zenith angle + ozout(9,itx)=hdrozg(5) ! solar azimuth angle ozout(10,itx)=hdrozg2(1) ! CLOUD AMOUNT IN SEGMENT ozout(11,itx)=hdrozg2(2) ! SNOW COVER ozout(12,itx)=hdrozg2(3) ! AEROSOL CONTAMINATION INDEX From dfb958fa9372c10c808d20e64f2955652017ee32 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 18 Mar 2024 15:27:23 -0400 Subject: [PATCH 13/35] Update Hera intel modulefile to Rocky 8 (#715) --- modulefiles/gsi_hera.intel.lua | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modulefiles/gsi_hera.intel.lua b/modulefiles/gsi_hera.intel.lua index 2d36f375e0..d21b9195c3 100644 --- a/modulefiles/gsi_hera.intel.lua +++ b/modulefiles/gsi_hera.intel.lua @@ -1,7 +1,7 @@ help([[ ]]) -prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") +prepend_path("MODULEPATH", "/scratch1/NCEPDEV/nems/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev-rocky8/install/modulefiles/Core") local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" From 4e8107c0ae054bc9dcc7b9a2684479d97a1e4261 Mon Sep 17 00:00:00 2001 From: "Tseganeh Z. Gichamo" Date: Tue, 19 Mar 2024 12:44:32 -0600 Subject: [PATCH 14/35] Add parallel netcdf read/write from EnKF for sfc files (paranc option) (#709) --- src/enkf/controlvec.f90 | 16 +- src/enkf/gridio_gfs.f90 | 453 +++++++++++++++++++++++++++++++++++++++- 2 files changed, 452 insertions(+), 17 deletions(-) diff --git a/src/enkf/controlvec.f90 b/src/enkf/controlvec.f90 index 808eae2e28..0961549634 100644 --- a/src/enkf/controlvec.f90 +++ b/src/enkf/controlvec.f90 @@ -191,7 +191,7 @@ subroutine read_control() ! read ensemble members on IO tasks implicit none real(r_double) :: t1,t2 -integer(i_kind) :: nb,ne +integer(i_kind) :: nb,nlev,ne integer(i_kind) :: q_ind integer(i_kind) :: ierr @@ -218,19 +218,23 @@ subroutine read_control() if (nproc == 0) t1 = mpi_wtime() call readgriddata_pnc(cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in readgrid_pnc on root',t2-t1,'secs' + end if end if if (nproc <= ntasks_io-1) then if (.not. paranc) then if (nproc == 0) t1 = mpi_wtime() call readgriddata(nanal1(nproc),nanal2(nproc),cvars3d,cvars2d,nc3d,nc2d,clevels,ncdim,nbackgrounds, & fgfileprefixes,fgsfcfileprefixes,reducedgrid,grdin,qsat) + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in readgrid on root',t2-t1,'secs' + end if end if !print *,'min/max qsat',nanal,'=',minval(qsat),maxval(qsat) q_ind = getindex(cvars3d, 'q') - if (nproc == 0) then - t2 = mpi_wtime() - print *,'time in readgridata on root',t2-t1,'secs' - end if if (pseudo_rh .and. q_ind > 0) then do ne=1,nanals_per_iotask do nb=1,nbackgrounds @@ -357,7 +361,7 @@ subroutine write_control(no_inflate_flag) endif deallocate(grdin_mean) t2 = mpi_wtime() - print *,'time in write_control on root',t2-t1,'secs' + print *,'time in write_control paranc on root',t2-t1,'secs' endif end if diff --git a/src/enkf/gridio_gfs.f90 b/src/enkf/gridio_gfs.f90 index 8afb012fcf..35a0c3fbe4 100644 --- a/src/enkf/gridio_gfs.f90 +++ b/src/enkf/gridio_gfs.f90 @@ -89,15 +89,21 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & real(r_kind), dimension(ndimspec) :: vrtspec,divspec real(r_kind), allocatable, dimension(:) :: psg,pstend,ak,bk real(r_single),allocatable,dimension(:,:,:) :: ug3d,vg3d - type(Dataset) :: dset + type(Dataset) :: dset, dset_sfc type(Dimension) :: londim,latdim,levdim integer(i_kind) :: u_ind, v_ind, tv_ind, q_ind, oz_ind, cw_ind integer(i_kind) :: qr_ind, qs_ind, qg_ind integer(i_kind) :: tsen_ind, ql_ind, qi_ind, prse_ind integer(i_kind) :: ps_ind, pst_ind, sst_ind + ! surface + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind, soilt3_ind + integer(i_kind) :: soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: k,iret,nb,i,imem,idvc,nlonsin,nlatsin,nlevsin,ne,nanal + ! surface + integer(i_kind) :: nlonsin_sfc,nlatsin_sfc + logical ice logical use_full_hydro integer(i_kind), allocatable, dimension(:) :: mem_pe, lev_pe1, lev_pe2, iocomms @@ -111,12 +117,6 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, read_sfc_file, read_atm_file) - if (read_sfc_file) then - print *,'paranc not supported for reading surface files' - call mpi_barrier(mpi_comm_world,ierr) - call mpi_finalize(ierr) - endif - ! figure out what member to read and do MPI sub-communicator things allocate(mem_pe(0:numproc-1)) allocate(iocomms(nanals)) @@ -152,6 +152,7 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & displs(i+1) = ((lev_pe1(i)-1)*nlons*nlats) end do + if (read_atm_file) then ! loop through times and do the read ne = 1 @@ -159,7 +160,6 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & write(charnanal,'(a3, i3.3)') 'mem', nanal filename = trim(adjustl(datapath))//trim(adjustl(fileprefixes(nb)))//trim(charnanal) - sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) if (use_gfs_ncio) then dset = open_dataset(filename, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) londim = get_dim(dset,'grid_xt'); nlonsin = londim%len @@ -496,6 +496,141 @@ subroutine readgriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,ntimes, & end do backgroundloop ! loop over backgrounds to read in + end if !read_atm_file + + if (read_sfc_file) then + ! loop through times and do the read + ne = 1 + sfcbackgroundloop: do nb=1,ntimes + + write(charnanal,'(a3, i3.3)') 'mem', nanal + sfcfilename = trim(adjustl(datapath))//trim(adjustl(filesfcprefixes(nb)))//trim(charnanal) + if (use_gfs_ncio) then + dset_sfc = open_dataset(sfcfilename, paropen=.true., mpicomm=iocomms(mem_pe(nproc))) + else + write(6,*)'READGRIDDATA_PNC sfc: ***FATAL ERROR*** parallel read only supported for netCDF' , ' PROGRAM STOPS' + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) + end if + if ( reducedgrid ) then + write(6,*) "READGRIDDATA_PNC sfc: reducedgrid=T interpolation not valid for writing sfc files" + call mpi_barrier(mpi_comm_world,ierr) + call mpi_finalize(ierr) + endif + + ! land sfc DA variables + tmp2m_ind = getindex(vars2d, 't2m') + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + ! read in sfc vars, if requested + if (tmp2m_ind > 0) then + call read_vardata(dset_sfc, 'tmp2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading tmp2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + tmp2m_ind,nb,ne)) + endif + if (spfh2m_ind > 0) then + call read_vardata(dset_sfc, 'spfh2m', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading spfh2m' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + spfh2m_ind,nb,ne)) + endif + if (soilt1_ind > 0) then + call read_vardata(dset_sfc, 'soilt1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt1_ind,nb,ne)) + endif + if (soilt2_ind > 0) then + call read_vardata(dset_sfc, 'soilt2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt2_ind,nb,ne)) + endif + if (soilt3_ind > 0) then + call read_vardata(dset_sfc, 'soilt3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt3_ind,nb,ne)) + endif + if (soilt4_ind > 0) then + call read_vardata(dset_sfc, 'soilt4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soilt2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + soilt4_ind,nb,ne)) + endif + if (slc1_ind > 0) then + call read_vardata(dset_sfc, 'soill1', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill1' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc1_ind,nb,ne)) + endif + if (slc2_ind > 0) then + call read_vardata(dset_sfc, 'soill2', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill2' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc2_ind,nb,ne)) + endif + if (slc3_ind > 0) then + call read_vardata(dset_sfc, 'soill3', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill3' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc3_ind,nb,ne)) + endif + if (slc4_ind > 0) then + call read_vardata(dset_sfc, 'soill4', values_2d, errcode=iret) + if (iret /= 0) then + print *,'READGRIDDATA_PNC: error reading soill4' + call stop2(22) + endif + ug = reshape(values_2d,(/nlons*nlats/)) + if (iope==0) call copytogrdin(ug,grdin(:,levels(n3d) + slc4_ind,nb,ne)) + endif + + ! bring all the subdomains back to the main PE + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + if (allocated(values_2d)) deallocate(values_2d) + call close_dataset(dset_sfc) + call mpi_barrier(iocomms(mem_pe(nproc)), iret) + + end do sfcbackgroundloop ! loop over backgrounds to read in + end if !if (read_sfc_file) + ! remove the sub communicators call mpi_barrier(iocomms(mem_pe(nproc)), iret) call mpi_comm_free(iocomms(mem_pe(nproc)), iret) @@ -1322,6 +1457,20 @@ subroutine writegriddata_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_ integer(i_kind) :: ncstart(4), nccount(4) logical :: nocompress + logical :: write_sfc_file, write_atm_file + character(len=max_varname_length), dimension(n3d) :: no_vars3d + character(len=max_varname_length), dimension(n2d) :: no_vars2d + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + + if (write_sfc_file ) then + ! adding the sfc increments requires adjusting several other variables. + ! This is done is a separate program. + if (nproc == 0) write(6,*) 'gridio/writegriddata_pnc: not coded to write sfc analysis, will write increment for sfc fields' + no_vars3d='' + call writeincrement_pnc(no_vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) + endif + nocompress = .true. if (nccompress) nocompress = .false. @@ -3616,6 +3765,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, ! soil / snow mask (not fixed) integer(i_kind), dimension(nlons,nlats) :: mask logical :: write_sfc_file, write_atm_file + real(r_double) :: t1,t2 call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) @@ -3627,6 +3777,7 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, nccount = (/nlons, nlats, nlevs/) if ( write_atm_file) then + if (nproc == 0) t1 = mpi_wtime() ne = 0 ensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -3954,10 +4105,15 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, end do backgroundloop ! loop over backgrounds to read in end do ensmemloop ! loop over ens members to read in + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement atm_file on root',t2-t1,'secs' + endif endif ! write_atm_file if (write_sfc_file) then + if (nproc == 0) t1 = mpi_wtime() ne = 0 sfcensmemloop: do nanal=nanal1,nanal2 ne = ne + 1 @@ -4199,6 +4355,10 @@ subroutine writeincrement(nanal1,nanal2,vars3d,vars2d,n3d,n2d,levels,ndim,grdin, end do sfcbackgroundloop ! loop over backgrounds to read in end do sfcensmemloop ! loop over ens members to read in + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement sfc_file on root',t2-t1,'secs' + endif endif ! write_sfc_file @@ -4225,7 +4385,8 @@ end subroutine writeincrement subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate_flag) use netcdf use params, only: nbackgrounds,incfileprefixes,fgfileprefixes,reducedgrid,& - datestring,nhr_anal + datestring,nhr_anal, & + incsfcfileprefixes,fgsfcfileprefixes use constants, only: grav,qcmin use mpi use module_ncio, only: Dataset, Variable, Dimension, open_dataset,& @@ -4257,12 +4418,17 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate integer :: ql_ind, qi_ind, qr_ind, qs_ind, qg_ind ! netcdf things - integer(i_kind) :: dimids3(3),nccount(3),ncstart(3) + integer(i_kind) :: dimids3(3),nccount(3),ncstart(3), dimids2(2) integer(i_kind) :: ncid_out, lon_dimid, lat_dimid, lev_dimid, ilev_dimid integer(i_kind) :: lonvarid, latvarid, levvarid, pfullvarid, ilevvarid, & hyaivarid, hybivarid, uvarid, vvarid, delpvarid, delzvarid, & tvarid, sphumvarid, liqwatvarid, o3varid, icvarid, & - rwmrvarid, snmrvarid, grlevarid + rwmrvarid, snmrvarid, grlevarid, & + tmp2mvarid, spfh2mvarid, soilt1varid, soilt2varid, & + soilt3varid, soilt4varid, slc1varid, slc2varid, & + slc3varid, slc4varid, maskvarid + integer(i_kind) :: tmp2m_ind, spfh2m_ind, soilt1_ind, soilt2_ind,soilt3_ind, & + soilt4_ind,slc1_ind, slc2_ind, slc3_ind, slc4_ind integer(i_kind) :: iadateout ! fixed fields such as lat, lon, levs @@ -4274,11 +4440,20 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate ! increment real(r_kind), dimension(nlons*nlats) :: psinc, inc, ug, vg, work real(r_single), allocatable, dimension(:,:,:) :: inc3d, inc3d2, inc3dout + real(r_single), allocatable, dimension(:,:) :: inc2d, inc2dout real(r_single), allocatable, dimension(:,:,:) :: tv, tvanl, tmp, tmpanl, q, qanl real(r_single), allocatable, dimension(:,:,:) :: q2, qanl2 real(r_kind), allocatable, dimension(:,:) :: values_2d real(r_kind), allocatable, dimension(:) :: psges, delzb, values_1d + ! soil / snow mask (not fixed) + integer(i_kind), dimension(nlons,nlats) :: mask + + logical :: write_sfc_file, write_atm_file + real(r_double) :: t1,t2 + + call set_ncio_file_flags(vars3d, n3d, vars2d, n2d, write_sfc_file, write_atm_file) + use_full_hydro = .false. clip = tiny_r_kind read(datestring,*) iadateout @@ -4317,6 +4492,9 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate call mpi_bcast(grdin(1,1,nb,1),npts*ndim, mpi_real4, 0, iocomms(mem_pe(nproc)), iret) enddo + if (write_atm_file ) then + + if (nproc == 0) t1 = mpi_wtime() ! loop through times and do the read ne = 1 backgroundloop: do nb=1,nbackgrounds @@ -4772,8 +4950,261 @@ subroutine writeincrement_pnc(vars3d,vars2d,n3d,n2d,levels,ndim,grdin,no_inflate if (allocated(delzb)) deallocate(delzb) if (allocated(psges)) deallocate(psges) + !closing file + call nccheck_incr(nf90_close(ncid_out)) end do backgroundloop ! loop over backgrounds to write out + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement_pnc atm_file on root',t2-t1,'secs' + endif + end if ! if (write_atm_file) + + if (write_sfc_file ) then + + if (nproc == 0) t1 = mpi_wtime() + + tmp2m_ind = getindex(vars2d, 't2m') !< indices in the state or control var arrays + spfh2m_ind = getindex(vars2d, 'q2m') + soilt1_ind = getindex(vars2d, 'st1') + slc1_ind = getindex(vars2d, 'sl1') + soilt2_ind = getindex(vars2d, 'st2') + slc2_ind = getindex(vars2d, 'sl2') + soilt3_ind = getindex(vars2d, 'st3') + slc3_ind = getindex(vars2d, 'sl3') + soilt4_ind = getindex(vars2d, 'st4') + slc4_ind = getindex(vars2d, 'sl4') + + ! loop through times and do the read + ne = 1 + write(charnanal,'(i3.3)') nanal + sfcbackgroundloop: do nb=1,nbackgrounds + + if(no_inflate_flag) then + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"nimem"//charnanal + else + filenameout = trim(adjustl(datapath))//trim(adjustl(incsfcfileprefixes(nb)))//"mem"//charnanal + end if + filenamein = trim(adjustl(datapath))//trim(adjustl(fgsfcfileprefixes(nb)))//"mem"//charnanal + + !! note: only iope=0 is writing the outputs. Having all pes in iocomm write to a file slows it down. + !! + if (iope==0) then + dsfg = open_dataset(filenamein) + ! create the output netCDF increment file + call nccheck_incr(nf90_create(path=trim(filenameout), cmode=nf90_netcdf4,ncid=ncid_out)) + + ! create dimensions based on analysis resolution, not guess + call nccheck_incr(nf90_def_dim(ncid_out, "longitude", nlons, lon_dimid)) + call nccheck_incr(nf90_def_dim(ncid_out, "latitude", nlats, lat_dimid)) + dimids2 = (/ lon_dimid, lat_dimid /) + ! create variables + call nccheck_incr(nf90_def_var(ncid_out, "longitude", nf90_real,(/lon_dimid/), lonvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "latitude", nf90_real,(/lat_dimid/), latvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "tmp2m_inc", nf90_real, dimids2,tmp2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "spfh2m_inc", nf90_real, dimids2,spfh2mvarid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt1_inc", nf90_real, dimids2,soilt1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt2_inc", nf90_real, dimids2,soilt2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt3_inc", nf90_real, dimids2,soilt3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilt4_inc", nf90_real, dimids2,soilt4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc1_inc", nf90_real, dimids2,slc1varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc2_inc", nf90_real, dimids2,slc2varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc3_inc", nf90_real, dimids2,slc3varid)) + call nccheck_incr(nf90_def_var(ncid_out, "slc4_inc", nf90_real, dimids2,slc4varid)) + call nccheck_incr(nf90_def_var(ncid_out, "soilsnow_mask", nf90_int,dimids2, maskvarid)) + ! place global attributes to serial calc_increment output + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "source", "GSI EnKF")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "comment", & + "global landsfc anal increment from writeincrement")) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global, "analysis_time",iadateout)) + call nccheck_incr(nf90_put_att(ncid_out, nf90_global,"IAU_hour_from_guess", nhr_anal(nb))) + ! add units to lat/lon because that's what the calc_increment utility has + call nccheck_incr(nf90_put_att(ncid_out, lonvarid, "units","degrees_east")) + call nccheck_incr(nf90_put_att(ncid_out, latvarid, "units","degrees_north")) + ! end the netCDF file definition + call nccheck_incr(nf90_enddef(ncid_out)) + + ! longitudes + call read_vardata(dsfg, 'grid_xt', values_1d, errcode=iret) + deglons(:) = values_1d + call nccheck_incr(nf90_put_var(ncid_out, lonvarid, deglons, & + start = (/1/), count = (/nlons/))) + + call read_vardata(dsfg, 'grid_yt', values_1d, errcode=iret) + ! latitudes + do j=1,nlats + deglats(nlats-j+1) = values_1d(j) + end do + call nccheck_incr(nf90_put_var(ncid_out, latvarid, deglats, & + start = (/1/), count = (/nlats/))) + ! construct mask (1 - soil, 2 - snow, 0 - not snow) + ! note: same logic/threshold used in global_cycle to produce + ! mask on model grid. + call read_vardata(dsfg, 'soill1', values_2d, errcode=iret) + mask = 0 + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .LT. 1.0) then + mask(i,nlats-j+1) = 1 + endif + enddo + end do + call read_vardata(dsfg, 'weasd', values_2d, errcode=iret) + do j=1,nlats + do i = 1, nlons + if (values_2d(i,j) .GT. 0.001) then + mask(i,nlats-j+1) = 2 + endif + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, maskvarid, mask, & + start = ncstart(1:2), count = nccount(1:2))) + + allocate(inc2d(nlons,nlats)) + allocate(inc2dout(nlons,nlats)) + + ! tmp2m increment + inc(:) = zero + if (tmp2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d) + tmp2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, tmp2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! spfh2m increment + inc(:) = zero + if (spfh2m_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+spfh2m_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, spfh2mvarid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt1 increment + inc(:) = zero + if (soilt1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt2 increment + inc(:) = zero + if (soilt2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt3 increment + inc(:) = zero + if (soilt3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! soilt4 increment + inc(:) = zero + if (soilt4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+soilt4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + inc2dout=0. + do j=1,nlats + do i = 1, nlons + if (mask(i,nlats-j+1) .NE. 0) inc2dout(i,nlats-j+1) = inc2d(i,j) + enddo + end do + call nccheck_incr(nf90_put_var(ncid_out, soilt4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc1 increment + inc(:) = zero + if (slc1_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc1_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc1varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc2 increment + inc(:) = zero + if (slc2_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc2_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc2varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc3 increment + inc(:) = zero + if (slc3_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc3_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc3varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + ! slc4 increment + inc(:) = zero + if (slc4_ind > 0) then + call copyfromgrdin(grdin(:,levels(n3d)+slc4_ind,nb,ne),inc) + endif + inc2d(:,:) = reshape(inc,(/nlons,nlats/)) + do j=1,nlats + inc2dout(:,nlats-j+1) = inc2d(:,j) + end do + call nccheck_incr(nf90_put_var(ncid_out, slc4varid, sngl(inc2dout), & + start = ncstart(1:2), count = nccount(1:2))) + + call close_dataset(dsfg,errcode=iret) + if (iret/=0) then + write(6,*)'gridio/writeincrement_par: problem closing netcdf sfc fg dataset, iret=',iret + call stop2(23) + endif + ! deallocate things + deallocate(inc2d,inc2dout) + + call nccheck_incr(nf90_close(ncid_out)) + + end if + + end do sfcbackgroundloop ! loop over backgrounds to read in + if (nproc == 0) then + t2 = mpi_wtime() + print *,'time in writeincrement_pnc sfc_file on root',t2-t1,'secs' + endif + endif !write_Sfc + ! remove the sub communicators call mpi_barrier(iocomms(mem_pe(nproc)), iret) call mpi_comm_free(iocomms(mem_pe(nproc)), iret) From 2167bc93fe2b1e84657822a323666ccc61f9a339 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA Date: Wed, 20 Mar 2024 12:16:42 -0400 Subject: [PATCH 15/35] =?UTF-8?q?Issue=20694:=20Upgrade/refactoring=20for?= =?UTF-8?q?=20U=20and=20V=20write-out=20sub=20for=20FV3REG=20GSI=20failure?= =?UTF-8?q?=20=E2=80=A6=20(#698)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit **DUE DATE for merger of this PR into `develop` is 3/27/2024 (six weeks after PR creation).** Resolves #693 (Thanks to @edwardhartnett 's suggestions) Resolves # 694 ( this PR is not able to provide a stable solution, more details would be given on the issue page) Resolves # 697: With larger requested memory for each mpi task, it still showed, for some time, the differences in the analysis files between loproc vs hiproc for the control runs on hercules. whether integrating this with the refactored IO part would provide a stable solution remains to be seen. This PR resolved the newly emerged issue with IO of netcdf files in the continuous storage, with upgraded FV3REG IO for the cold start options. (Co author Ming Hu @hu5970 ) This PR is being worked on in collaboration with Pete Johnson through RDHPCS help desk, @RussTreadon-NOAA @DavidHuber-NOAA and thanks to help from @ed Raghue Reddy through RDHPCS help desk. --------- Co-authored-by: Ting Lei Co-authored-by: Ting.Lei-NOAA --- regression/regression_driver.sh | 2 + regression/regression_param.sh | 48 +-- src/gsi/gsi_rfv3io_mod.f90 | 542 ++++++++++++++++++++------------ ush/sub_hera | 5 +- ush/sub_hercules | 4 +- ush/sub_jet | 2 +- ush/sub_orion | 2 +- 7 files changed, 365 insertions(+), 240 deletions(-) diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index 821cc7cedb..38329778a4 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -36,10 +36,12 @@ for jn in `seq ${RSTART} ${REND}`; do export scripts=${scripts_updat:-$scripts} export fixgsi=${fixgsi_updat:-$fixgsi} export modulefiles=${modulefiles_updat:-$modulefiles} + export ush=${ush_update:-$ush} else export scripts=${scripts_contrl:-$scripts} export fixgsi=${fixgsi_contrl:-$fixgsi} export modulefiles=${modulefiles_contrl:-$modulefiles} + export ush=${ush_cntrl:-$ush} fi rm -f ${job[$jn]}.out diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 2ac615fc4a..a4f5d7035c 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -87,17 +87,17 @@ case $regtest in rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -117,17 +117,17 @@ case $regtest in hafs_3denvar_hybens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[2]="0:15:00" ; popts[2]="5/8/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -146,17 +146,17 @@ case $regtest in hafs_4denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" + topts[1]="0:20:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:20:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:20:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:20:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:20:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" @@ -300,10 +300,10 @@ if [[ "$machine" = "Hera" ]]; then export APRUN="srun" elif [[ "$machine" = "Orion" ]]; then export OMP_STACKSIZE=2048M - export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" + export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads" elif [[ "$machine" = "Hercules" ]]; then export OMP_STACKSIZE=2048M - export APRUN="srun -n \$ntasks --cpus-per-task=\$threads" + export APRUN="srun -n \$ntasks --mem=0 --cpus-per-task=\$threads" elif [[ "$machine" = "Jet" ]]; then export OMP_STACKSIZE=1024M export MPI_BUFS_PER_PROC=256 diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index b3f3488a70..652bad9a33 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -547,7 +547,7 @@ subroutine gsi_rfv3io_get_ens_grid_specs(grid_spec,ierr) ! !$$$ end documentation block use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use mpimod, only: mype use mod_fv3_lola, only: definecoef_regular_grids @@ -1238,7 +1238,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) fv3lam_io_phymetvars3d_nouv(jphyvar)=trim(vartem) else write(6,*)'the metvarname ',vartem,' is not expected, stop' - call flush(6) call stop2(333) endif endif @@ -1253,7 +1252,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif if(jdynvar /= ndynvario3d.or.jtracer /= ntracerio3d.or.jphyvar /= nphyvario3d ) then write(6,*)'ndynvario3d is not as expected, stop' - call flush(6) call stop2(333) endif if(mype == 0) then @@ -1361,7 +1359,6 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) else if (trim(vartem) /= "pm2_5")then write(6,*)'the chemvarname ',vartem,' is not in aeronames_smoke_fv3 !!!' - call flush(6) endif endif enddo @@ -1598,7 +1595,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if( fv3sar_bg_opt == 0) then call gsi_fv3ncdf_readuv(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) else - call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) + call gsi_fv3ncdf_readuv_v1(grd_fv3lam_uv,ges_u,ges_v,fv3filenamegin(it),.false.) endif if( fv3sar_bg_opt == 0) then @@ -2449,7 +2446,7 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens use mpimod, only: mpi_comm_world,mpi_rtype,mype,npe,setcomm,mpi_integer,mpi_max use mpimod, only: MPI_INFO_NULL use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens @@ -2469,9 +2466,9 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens character(len=max_varname_length) :: name character(len=max_filename_length) :: filenamein2 real(r_kind),allocatable,dimension(:,:):: uu2d_tmp - integer(i_kind) :: countloc_tmp(3),startloc_tmp(3) + integer(i_kind) :: countloc_tmp(4),startloc_tmp(4) - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4) integer(i_kind) ilev,ilevtot,inative integer(i_kind) kbgn,kend,len logical :: phy_smaller_domain @@ -2528,18 +2525,16 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio - iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + iret=nf90_open(filename_layout,ior(nf90_nowrite,nf90_mpiio),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -2554,15 +2549,14 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens name=trim(varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) nz=grd_ionouv%nsig nzp1=nz+1 inative=nzp1-ilev - startloc=(/1,1,inative/) - countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative,1/) + countloc=(/nxcase,nycase,1,1/) ! Variable ref_f3d in phy_data.nc has a smaller domain size than ! dynvariables and tracers as well as a reversed order in vertical if ( trim(adjustl(varname)) == 'ref_f3d' .or. trim(adjustl(varname)) == 'flash_extent_density' )then @@ -2570,23 +2564,23 @@ subroutine gsi_fv3ncdf_read(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin,ens if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then allocate(uu2d_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) + countloc_tmp=(/nxcase,nycase,1,1/) phy_smaller_domain = .false. else allocate(uu2d_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) + countloc_tmp=(/nxcase-6,nycase-6,1,1/) phy_smaller_domain = .true. end if - startloc_tmp=(/1,1,ilev/) + startloc_tmp=(/1,1,ilev,1/) end if if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 if (ensgrid) then - countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + countloc=(/nxcase,ny_layout_lenens(nio)+1,1,1/) allocate(uu2d_layout(nxcase,ny_layout_lenens(nio)+1)) else - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(uu2d_layout(nxcase,ny_layout_len(nio))) end if iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) @@ -2671,10 +2665,10 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, use kinds, only: r_kind,i_kind - use mpimod, only: mpi_rtype,mpi_comm_world,mype,MPI_INFO_NULL - use mpimod, only: mpi_comm_world,mpi_rtype,mype + use mpimod, only: npe,mpi_rtype,mpi_comm_world,mype,MPI_INFO_NULL + use mpimod, only: mpi_comm_world,mpi_rtype,mype,setcomm,mpi_integer,mpi_max use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens @@ -2694,12 +2688,18 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, character(len=max_varname_length) :: varname,vgsiname - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4) integer(i_kind) kbgn,kend integer(i_kind) var_id integer(i_kind) inative,ilev,ilevtot integer(i_kind) gfile_loc,iret integer(i_kind) nzp1,mm1 + + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse + + mm1=mype+1 @@ -2712,13 +2712,34 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, nxcase=nx nycase=ny end if + allocate(uu2d(nxcase,nycase)) + kbgn=grd_ionouv%kbegin_loc kend=grd_ionouv%kend_loc - allocate(uu2d(nxcase,nycase)) - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif @@ -2728,15 +2749,14 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) nz=grd_ionouv%nsig nzp1=nz+1 inative=nzp1-ilev - startloc=(/1,1,inative+1/) - countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative+1,1/) + countloc=(/nxcase,nycase,1,1/) iret=nf90_inq_varid(gfile_loc,trim(adjustl(varname)),var_id) if(iret/=nf90_noerr) then write(6,*)' wrong to get var_id ',var_id @@ -2752,8 +2772,9 @@ subroutine gsi_fv3ncdf_read_v1(grd_ionouv,cstate_nouv,filenamein,fv3filenamegin, end if enddo ! i - call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) iret=nf90_close(gfile_loc) + endif + call general_grid2sub(grd_ionouv,hwork,cstate_nouv%values) deallocate (uu2d) @@ -2785,7 +2806,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) use kinds, only: r_kind,i_kind use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null,npe,setcomm,mpi_integer,mpi_max use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3uv2earth,fv3_h_to_ll_ens,fv3uv2earthens @@ -2808,7 +2829,7 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) integer(i_kind) u_grd_VarId,v_grd_VarId integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase - integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4) integer(i_kind) inative,ilev,ilevtot integer(i_kind) kbgn,kend @@ -2873,15 +2894,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) if(iret/=nf90_noerr) then write(6,*)'problem opening6 ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' problem opening6 ',trim(filenamein),', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -2891,24 +2910,23 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_uv%lnames(1,ilevtot) nz=grd_uv%nsig nzp1=nz+1 inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) + u_countloc=(/nxcase,nycase+1,1,1/) + v_countloc=(/nxcase+1,nycase,1,1/) + u_startloc=(/1,1,inative,1/) + v_startloc=(/1,1,inative,1/) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 if (ensgrid) then - u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1/) + u_countloc=(/nxcase,ny_layout_lenens(nio)+1,1,1/) allocate(u2d_layout(nxcase,ny_layout_lenens(nio)+1)) else - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + u_countloc=(/nxcase,ny_layout_len(nio)+1,1,1/) allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) end if call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) @@ -2917,13 +2935,13 @@ subroutine gsi_fv3ncdf_readuv(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) u2d(:,ny_layout_bens(nio):ny_layout_eens(nio))=u2d_layout(:,1:ny_layout_lenens(nio)) if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_eens(nio)+1)=u2d_layout(:,ny_layout_lenens(nio)+1) deallocate(u2d_layout) - v_countloc=(/nxcase+1,ny_layout_lenens(nio),1/) + v_countloc=(/nxcase+1,ny_layout_lenens(nio),1,1/) allocate(v2d_layout(nxcase+1,ny_layout_lenens(nio))) else u2d(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) deallocate(u2d_layout) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + v_countloc=(/nxcase+1,ny_layout_len(nio),1,1/) allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) end if call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) @@ -3019,9 +3037,10 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) !$$$ end documentation block use constants, only: half use kinds, only: r_kind,i_kind - use mpimod, only: mpi_comm_world,mpi_rtype,mype,mpi_info_null + use mpimod, only: setcomm,mpi_integer,mpi_max, npe,mpi_comm_world,mpi_rtype,mype,mpi_info_null use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_var_par_access,nf90_netcdf4 use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use mod_fv3_lola, only: fv3_h_to_ll,fv3_h_to_ll_ens @@ -3051,6 +3070,9 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) integer(i_kind) nxcase,nycase integer(i_kind) us_countloc(3),us_startloc(3) integer(i_kind) vw_countloc(3),vw_startloc(3) + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)) mm1=mype+1 @@ -3067,11 +3089,33 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) kend=grd_uv%kend_loc allocate (us2d(nxcase,nycase+1),vw2d(nxcase+1,nycase)) allocate (uorv2d(nxcase,nycase)) + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + filenamein=fv3filenamegin%dynvars - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) !clt + iret=nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_nowrite,nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) !clt if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read_v1: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif @@ -3080,7 +3124,6 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) filenamein2=fv3filenamegin%dynvars if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_uv%lnames(1,ilevtot) @@ -3099,9 +3142,9 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) ! transfor to earth u/v, interpolate to analysis grid, reverse vertical order - iret=nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id) - - iret=nf90_get_var(gfile_loc,var_id,us2d,start=us_startloc,count=us_countloc) + call check(nf90_inq_varid(gfile_loc,trim(adjustl("u_s")),var_id)) + + call check(nf90_get_var(gfile_loc,var_id,us2d,start=us_startloc,count=us_countloc)) iret=nf90_inq_varid(gfile_loc,trim(adjustl("v_w")),var_id) iret=nf90_get_var(gfile_loc,var_id,vw2d,start=vw_startloc,count=vw_countloc) do j=1,ny @@ -3123,10 +3166,11 @@ subroutine gsi_fv3ncdf_readuv_v1(grd_uv,ges_u,ges_v,fv3filenamegin,ensgrid) end if enddo ! iilevtoto + iret=nf90_close(gfile_loc) + endif !procuse call general_grid2sub(grd_uv,hwork,worksub) ges_u=worksub(1,:,:,:) ges_v=worksub(2,:,:,:) - iret=nf90_close(gfile_loc) deallocate (us2d,vw2d,worksub) end subroutine gsi_fv3ncdf_readuv_v1 @@ -3160,7 +3204,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & use mpimod, only: mpi_comm_world,mpi_rtype,mype use mpimod, only: MPI_INFO_NULL use netcdf, only: nf90_open,nf90_close,nf90_get_var,nf90_noerr - use netcdf, only: nf90_nowrite,nf90_inquire,nf90_inquire_dimension + use netcdf, only: nf90_nowrite,nf90_mpiio,nf90_inquire,nf90_inquire_dimension use netcdf, only: nf90_inquire_variable use netcdf, only: nf90_inq_varid use gridmod, only: nsig,nlon,nlat @@ -3179,7 +3223,7 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & character(len=max_varname_length) :: name character(len=max_filename_length), allocatable,dimension(:) :: varname_files - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3),countloc_tmp(3),startloc_tmp(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4),countloc_tmp(4),startloc_tmp(4) integer(i_kind) ilev,ilevtot,inative,ivar integer(i_kind) kbgn,kend integer(i_kind) gfile_loc,iret,var_id @@ -3238,15 +3282,13 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo else - iret=nf90_open(filenamein,nf90_nowrite,gfile_loc) + iret=nf90_open(filenamein,ior(nf90_nowrite,nf90_mpiio),gfile_loc) if(iret/=nf90_noerr) then write(6,*)' gsi_fv3ncdf_read: problem opening ',trim(filenamein),gfile_loc,', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -3256,8 +3298,8 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & nz=nsig nzp1=nz+1 inative=nzp1-ilev - startloc=(/1,1,inative/) - countloc=(/nxcase,nycase,1/) + startloc=(/1,1,inative,1/) + countloc=(/nxcase,nycase,1,1/) varname = trim(varname_files(ivar)) ! Variable ref_f3d in phy_data.nc has a smaller domain size than ! dynvariables and tracers as well as a reversed order in vertical @@ -3266,19 +3308,19 @@ subroutine gsi_fv3ncdf_read_ens_parallel_over_ens(filenamein,fv3filenamegin, & if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then allocate(uu2d_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) + countloc_tmp=(/nxcase,nycase,1,1/) phy_smaller_domain = .false. else allocate(uu2d_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) + countloc_tmp=(/nxcase-6,nycase-6,1,1/) phy_smaller_domain = .true. end if - startloc_tmp=(/1,1,ilev/) + startloc_tmp=(/1,1,ilev,1/) end if if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(uu2d_layout(nxcase,ny_layout_len(nio))) iret=nf90_inq_varid(gfile_loc_layout(nio),trim(adjustl(varname)),var_id) iret=nf90_get_var(gfile_loc_layout(nio),var_id,uu2d_layout,start=startloc,count=countloc) @@ -3408,7 +3450,7 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i integer(i_kind) u_grd_VarId,v_grd_VarId integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase - integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4) integer(i_kind) inative,ilev,ilevtot integer(i_kind) kbgn,kend @@ -3442,7 +3484,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i iret=nf90_open(filename_layout,nf90_nowrite,gfile_loc_layout(nio),comm=mpi_comm_world,info=MPI_INFO_NULL) if(iret/=nf90_noerr) then write(6,*)'problem opening ',trim(filename_layout),gfile_loc_layout(nio),', Status = ',iret - call flush(6) call stop2(333) endif enddo @@ -3450,7 +3491,6 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i iret=nf90_open(filenamein,nf90_nowrite,gfile_loc) if(iret/=nf90_noerr) then write(6,*)' problem opening ',trim(filenamein),', Status = ',iret - call flush(6) call stop2(333) endif endif @@ -3459,14 +3499,14 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i nz=nsig nzp1=nz+1 inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) + u_countloc=(/nxcase,nycase+1,1,1/) + v_countloc=(/nxcase+1,nycase,1,1/) + u_startloc=(/1,1,inative,1/) + v_startloc=(/1,1,inative,1/) if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) + u_countloc=(/nxcase,ny_layout_len(nio)+1,1,1/) allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) call check( nf90_inq_varid(gfile_loc_layout(nio),'u',u_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),u_grd_VarId,u2d_layout,start=u_startloc,count=u_countloc) @@ -3474,7 +3514,7 @@ subroutine gsi_fv3ncdf_readuv_ens_parallel_over_ens(ges_u,ges_v,fv3filenamegin,i if(nio==fv3_io_layout_y-1) u2d(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) deallocate(u2d_layout) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) + v_countloc=(/nxcase+1,ny_layout_len(nio),1,1/) allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) call check( nf90_inq_varid(gfile_loc_layout(nio),'v',v_grd_VarId) ) iret=nf90_get_var(gfile_loc_layout(nio),v_grd_VarId,v2d_layout,start=v_startloc,count=v_countloc) @@ -3965,7 +4005,7 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & fv3uv2earth,earthuv2fv3 use netcdf, only: nf90_open,nf90_close,nf90_noerr - use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_write,nf90_mpiio,nf90_inq_varid,nf90_var_par_access,nf90_collective use netcdf, only: nf90_put_var,nf90_get_var use general_sub2grid_mod, only: sub2grid_info,general_sub2grid @@ -3984,11 +4024,11 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) integer(i_kind) inative,ilev,ilevtot integer(i_kind) nlatcase,nloncase integer(i_kind) nxcase,nycase - integer(i_kind) u_countloc(3),u_startloc(3),v_countloc(3),v_startloc(3) + integer(i_kind) u_countloc(4),u_startloc(4),v_countloc(4),v_startloc(4) character(:),allocatable:: filenamein ,varname real(r_kind),allocatable,dimension(:,:,:,:):: worksub real(r_kind),allocatable,dimension(:,:):: work_au,work_av - real(r_kind),allocatable,dimension(:,:):: work_bu,work_bv + real(r_kind),allocatable,dimension(:,:,:):: work_bu,work_bv real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2 real(r_kind),allocatable,dimension(:,:):: workbu2,workbv2 @@ -3997,10 +4037,12 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) logical:: procuse ! for fv3_io_layout_y > 1 - real(r_kind),allocatable,dimension(:,:):: u2d_layout,v2d_layout + real(r_kind),allocatable,dimension(:,:,:):: u2d_layout,v2d_layout integer(i_kind) :: nio integer(i_kind),allocatable :: gfile_loc_layout(:) character(len=180) :: filename_layout + integer(i_kind):: kend_native,kbgn_native + integer(i_kind):: istat mm1=mype+1 @@ -4012,8 +4054,6 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) kend=grd_uv%kend_loc allocate( u2d(nlon_regional,nlat_regional+1)) allocate( v2d(nlon_regional+1,nlat_regional)) - allocate( work_bu(nlon_regional,nlat_regional+1)) - allocate( work_bv(nlon_regional+1,nlat_regional)) allocate (worksub(2,grd_uv%lat2,grd_uv%lon2,grd_uv%nsig)) allocate( work_au(nlatcase,nloncase),work_av(nlatcase,nloncase)) do k=1,grd_uv%nsig @@ -4054,59 +4094,70 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 write(filename_layout,'(a,a,I4.4)') trim(filenamein),".",nio - call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filename_layout,ior(nf90_write, nf90_mpiio),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) enddo gfile_loc=gfile_loc_layout(0) else - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + endif + nz=grd_uv%nsig + nzp1=nz+1 + kend_native=nzp1-grd_uv%lnames(1,kbgn) + kbgn_native=nzp1-grd_uv%lnames(1,kend) + allocate( work_bu(nlon_regional,nlat_regional+1,kbgn_native:kend_native)) + allocate( work_bv(nlon_regional+1,nlat_regional,kbgn_native:kend_native)) + u_startloc=(/1,1,kbgn_native,1/) + u_countloc=(/nxcase,nycase+1,kend_native-kbgn_native+1,1/) + v_startloc=(/1,1,kbgn_native,1/) + v_countloc=(/nxcase+1,nycase,kend_native-kbgn_native+1,1/) + if(fv3_io_layout_y > 1) then + do nio=0,fv3_io_layout_y-1 + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1)) + u_countloc=(/nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1,1/) + call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) + work_bu(:,ny_layout_b(nio):ny_layout_e(nio),:)=u2d_layout(:,1:ny_layout_len(nio),:) + if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1,:)=u2d_layout(:,ny_layout_len(nio)+1,:) + deallocate(u2d_layout) + + allocate(v2d_layout(nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1)) + v_countloc=(/nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1,1/) + call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) + work_bv(:,ny_layout_b(nio):ny_layout_e(nio),:)=v2d_layout + deallocate(v2d_layout) + enddo + else + call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) + call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, ugrd_VarId, nf90_collective)) + call check( nf90_var_par_access(gfile_loc, vgrd_VarId, nf90_collective)) + call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) + call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) endif + + do ilevtot=kbgn,kend varname=grd_uv%names(1,ilevtot) ilev=grd_uv%lnames(1,ilevtot) - nz=grd_uv%nsig - nzp1=nz+1 inative=nzp1-ilev - u_countloc=(/nxcase,nycase+1,1/) - v_countloc=(/nxcase+1,nycase,1/) - u_startloc=(/1,1,inative/) - v_startloc=(/1,1,inative/) work_au=hwork(1,:,:,ilevtot) work_av=hwork(2,:,:,ilevtot) - call check( nf90_inq_varid(gfile_loc,'u',ugrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v',vgrd_VarId) ) if(add_saved)then allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase)) allocate( workbu2(nlon_regional,nlat_regional+1)) allocate( workbv2(nlon_regional+1,nlat_regional)) !!!!!!!! readin work_b !!!!!!!!!!!!!!!! - if(fv3_io_layout_y > 1) then - do nio=0,fv3_io_layout_y-1 - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - call check( nf90_get_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) - work_bu(:,ny_layout_b(nio):ny_layout_e(nio))=u2d_layout(:,1:ny_layout_len(nio)) - if(nio==fv3_io_layout_y-1) work_bu(:,ny_layout_e(nio)+1)=u2d_layout(:,ny_layout_len(nio)+1) - deallocate(u2d_layout) - - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - call check( nf90_get_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) - work_bv(:,ny_layout_b(nio):ny_layout_e(nio))=v2d_layout - deallocate(v2d_layout) - enddo - else - call check( nf90_get_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) - call check( nf90_get_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) - endif + +!clt for fv3_io_layout<=1 now the nf90_get_var has been moved outside of this do loop +!to avoid failure on hercules when L_MPI_EXTRA_FILESYSTEM=1 if(.not.grid_reverse_flag) then - call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) - call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) + call reverse_grid_r_uv(work_bu(:,:,inative),nlon_regional,nlat_regional+1,1) + call reverse_grid_r_uv(work_bv(:,:,inative),nlon_regional+1,nlat_regional,1) endif - call fv3uv2earth(work_bu,work_bv,nlon_regional,nlat_regional,u2d,v2d) + call fv3uv2earth(work_bu(:,:,inative),work_bv(:,:,inative),nlon_regional,nlat_regional,u2d,v2d) call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,.true.) !!!!!!!! find analysis_inc: work_a !!!!!!!!!!!!!!!! @@ -4116,38 +4167,38 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,workbu2,workbv2) !!!!!!!! add analysis_inc to readin work_b !!!!!!!!!!!!!!!! - work_bu(:,:)=work_bu(:,:)+workbu2(:,:) - work_bv(:,:)=work_bv(:,:)+workbv2(:,:) + work_bu(:,:,inative)=work_bu(:,:,inative)+workbu2(:,:) + work_bv(:,:,inative)=work_bv(:,:,inative)+workbv2(:,:) deallocate(workau2,workbu2,workav2,workbv2) else call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,.true.) - call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:),work_bv(:,:)) + call earthuv2fv3(u2d,v2d,nlon_regional,nlat_regional,work_bu(:,:,inative),work_bv(:,:,inative)) endif if(.not.grid_reverse_flag) then - call reverse_grid_r_uv(work_bu,nlon_regional,nlat_regional+1,1) - call reverse_grid_r_uv(work_bv,nlon_regional+1,nlat_regional,1) + call reverse_grid_r_uv(work_bu(:,:,inative),nlon_regional,nlat_regional+1,1) + call reverse_grid_r_uv(work_bv(:,:,inative),nlon_regional+1,nlat_regional,1) endif + enddo !ilevltot - if(fv3_io_layout_y > 1) then + if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - allocate(u2d_layout(nxcase,ny_layout_len(nio)+1)) - u_countloc=(/nxcase,ny_layout_len(nio)+1,1/) - u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1) + allocate(u2d_layout(nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1)) + u_countloc=(/nxcase,ny_layout_len(nio)+1,kend_native-kbgn_native+1,1/) + u2d_layout=work_bu(:,ny_layout_b(nio):ny_layout_e(nio)+1,:) call check( nf90_put_var(gfile_loc_layout(nio),ugrd_VarId,u2d_layout,start=u_startloc,count=u_countloc) ) deallocate(u2d_layout) - allocate(v2d_layout(nxcase+1,ny_layout_len(nio))) - v_countloc=(/nxcase+1,ny_layout_len(nio),1/) - v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio)) + allocate(v2d_layout(nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1)) + v_countloc=(/nxcase+1,ny_layout_len(nio),kend_native-kbgn_native+1,1/) + v2d_layout=work_bv(:,ny_layout_b(nio):ny_layout_e(nio),:) call check( nf90_put_var(gfile_loc_layout(nio),vgrd_VarId,v2d_layout,start=v_startloc,count=v_countloc) ) deallocate(v2d_layout) enddo - else + else call check( nf90_put_var(gfile_loc,ugrd_VarId,work_bu,start=u_startloc,count=u_countloc) ) call check( nf90_put_var(gfile_loc,vgrd_VarId,work_bv,start=v_startloc,count=v_countloc) ) - endif - enddo !ilevltot + endif if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 @@ -4157,11 +4208,12 @@ subroutine gsi_fv3ncdf_writeuv(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) else call check( nf90_close(gfile_loc) ) endif + deallocate(work_bu,work_bv) endif call mpi_barrier(mpi_comm_world,ierror) - deallocate(work_bu,work_bv,u2d,v2d) + deallocate(u2d,v2d) deallocate(work_au,work_av) end subroutine gsi_fv3ncdf_writeuv @@ -4193,12 +4245,12 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) !$$$ end documentation block use constants, only: half,zero - use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null + use mpimod, only: npe, setcomm,mpi_integer,mpi_max,mpi_rtype,mpi_comm_world,mype,mpi_info_null use gridmod, only: nlon_regional,nlat_regional use mod_fv3_lola, only: fv3_ll_to_h,fv3_h_to_ll, & fv3uv2earth,earthuv2fv3 use netcdf, only: nf90_open,nf90_close,nf90_noerr - use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_write, nf90_mpiio,nf90_inq_varid,nf90_var_par_access,nf90_collective use netcdf, only: nf90_put_var,nf90_get_var use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none @@ -4220,14 +4272,20 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) integer(i_kind) inative,ilev,ilevtot real(r_kind),allocatable,dimension(:,:,:,:):: worksub real(r_kind),allocatable,dimension(:,:):: work_au,work_av - real(r_kind),allocatable,dimension(:,:):: work_bu_s,work_bv_s - real(r_kind),allocatable,dimension(:,:):: work_bu_w,work_bv_w + real(r_kind),allocatable,dimension(:,:,:):: work_bu_s,work_bv_s + real(r_kind),allocatable,dimension(:,:,:):: work_bu_w,work_bv_w real(r_kind),allocatable,dimension(:,:):: u2d,v2d,workau2,workav2 real(r_kind),allocatable,dimension(:,:):: workbu_s2,workbv_s2 real(r_kind),allocatable,dimension(:,:):: workbu_w2,workbv_w2 integer(i_kind) nlatcase,nloncase,nxcase,nycase - integer(i_kind) uw_countloc(3),us_countloc(3),uw_startloc(3),us_startloc(3) - integer(i_kind) vw_countloc(3),vs_countloc(3),vw_startloc(3),vs_startloc(3) + integer(i_kind) uw_countloc(4),us_countloc(4),uw_startloc(4),us_startloc(4) + integer(i_kind) vw_countloc(4),vs_countloc(4),vw_startloc(4),vs_startloc(4) + integer(i_kind):: kend_native,kbgn_native,kdim_native + + + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse mm1=mype+1 nloncase=grd_uv%nlon @@ -4249,61 +4307,96 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) allocate( u2d(nlon_regional,nlat_regional)) allocate( v2d(nlon_regional,nlat_regional)) - allocate( work_bu_s(nlon_regional,nlat_regional+1)) - allocate( work_bv_s(nlon_regional,nlat_regional+1)) - allocate( work_bu_w(nlon_regional+1,nlat_regional)) - allocate( work_bv_w(nlon_regional+1,nlat_regional)) allocate( work_au(nlatcase,nloncase),work_av(nlatcase,nloncase)) + if(add_saved) allocate( workau2(nlatcase,nloncase),workav2(nlatcase,nloncase)) - allocate( workbu_w2(nlon_regional+1,nlat_regional)) - allocate( workbv_w2(nlon_regional+1,nlat_regional)) - allocate( workbu_s2(nlon_regional,nlat_regional+1)) - allocate( workbv_s2(nlon_regional,nlat_regional+1)) + allocate( workbu_w2(nlon_regional+1,nlat_regional)) + allocate( workbv_w2(nlon_regional+1,nlat_regional)) + allocate( workbu_s2(nlon_regional,nlat_regional+1)) + allocate( workbv_s2(nlon_regional,nlat_regional+1)) filenamein=fv3filenamegin%dynvars - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL) ) - do ilevtot=kbgn,kend - varname=grd_uv%names(1,ilevtot) - ilev=grd_uv%lnames(1,ilevtot) - nz=grd_uv%nsig - nzp1=nz+1 - inative=nzp1-ilev + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + - uw_countloc= (/nlon_regional+1,nlat_regional,1/) - us_countloc= (/nlon_regional,nlat_regional+1,1/) - vw_countloc= (/nlon_regional+1,nlat_regional,1/) - vs_countloc= (/nlon_regional,nlat_regional+1,1/) + + + call check( nf90_open(filenamein,ior(nf90_write, nf90_mpiio),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + + call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, u_sgrd_VarId, nf90_collective)) + call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, u_wgrd_VarId, nf90_collective)) + call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, v_sgrd_VarId, nf90_collective)) + call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) ) + call check( nf90_var_par_access(gfile_loc, v_wgrd_VarId, nf90_collective)) + nz=grd_uv%nsig + nzp1=nz+1 + kend_native=nzp1-grd_uv%lnames(1,kbgn) + kbgn_native=nzp1-grd_uv%lnames(1,kend) + kdim_native=kend_native-kbgn_native+1 + + uw_countloc= (/nlon_regional+1,nlat_regional,kdim_native,1/) + us_countloc= (/nlon_regional,nlat_regional+1,kdim_native,1/) + vw_countloc= (/nlon_regional+1,nlat_regional,kdim_native,1/) + vs_countloc= (/nlon_regional,nlat_regional+1,kdim_native,1/) - uw_startloc=(/1,1,inative+1/) - us_startloc=(/1,1,inative+1/) - vw_startloc=(/1,1,inative+1/) - vs_startloc=(/1,1,inative+1/) + uw_startloc=(/1,1,kbgn_native+1,1/) !In the coldstart files, there is an extra top level + us_startloc=(/1,1,kbgn_native+1,1/) + vw_startloc=(/1,1,kbgn_native+1,1/) + vs_startloc=(/1,1,kbgn_native+1,1/) + allocate( work_bu_s(nlon_regional,nlat_regional+1,kbgn_native:kend_native)) + allocate( work_bv_s(nlon_regional,nlat_regional+1,kbgn_native:kend_native)) + allocate( work_bu_w(nlon_regional+1,nlat_regional,kbgn_native:kend_native)) + allocate( work_bv_w(nlon_regional+1,nlat_regional,kbgn_native:kend_native)) +!!!!!!!! readin work_b !!!!!!!!!!!!!!!! + call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) + call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) + call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) + call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) + do ilevtot=kbgn,kend + varname=grd_uv%names(1,ilevtot) + ilev=grd_uv%lnames(1,ilevtot) + inative=nzp1-ilev work_au=hwork(1,:,:,ilevtot) work_av=hwork(2,:,:,ilevtot) - call check( nf90_inq_varid(gfile_loc,'u_s',u_sgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'u_w',u_wgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v_s',v_sgrd_VarId) ) - call check( nf90_inq_varid(gfile_loc,'v_w',v_wgrd_VarId) ) -!!!!!!!! readin work_b !!!!!!!!!!!!!!!! - call check( nf90_get_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) - call check( nf90_get_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) - call check( nf90_get_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) - call check( nf90_get_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) if(add_saved)then do j=1,nlat_regional - u2d(:,j)=half * (work_bu_s(:,j)+ work_bu_s(:,j+1)) + u2d(:,j)=half * (work_bu_s(:,j,inative)+ work_bu_s(:,j+1,inative)) enddo do i=1,nlon_regional - v2d(i,:)=half*(work_bv_w(i,:)+work_bv_w(i+1,:)) + v2d(i,:)=half*(work_bv_w(i,:,inative)+work_bv_w(i+1,:,inative)) enddo call fv3_h_to_ll(u2d,workau2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) call fv3_h_to_ll(v2d,workav2,nlon_regional,nlat_regional,nloncase,nlatcase,grid_reverse_flag) @@ -4333,44 +4426,46 @@ subroutine gsi_fv3ncdf_writeuv_v1(grd_uv,ges_u,ges_v,add_saved,fv3filenamegin) - work_bu_w(:,:)=work_bu_w(:,:)+workbu_w2(:,:) - work_bu_s(:,:)=work_bu_s(:,:)+workbu_s2(:,:) - work_bv_w(:,:)=work_bv_w(:,:)+workbv_w2(:,:) - work_bv_s(:,:)=work_bv_s(:,:)+workbv_s2(:,:) + work_bu_w(:,:,inative)=work_bu_w(:,:,inative)+workbu_w2(:,:) + work_bu_s(:,:,inative)=work_bu_s(:,:,inative)+workbu_s2(:,:) + work_bv_w(:,:,inative)=work_bv_w(:,:,inative)+workbv_w2(:,:) + work_bv_s(:,:,inative)=work_bv_s(:,:,inative)+workbv_s2(:,:) else call fv3_ll_to_h(work_au(:,:),u2d,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) call fv3_ll_to_h(work_av(:,:),v2d,nloncase,nlatcase,nlon_regional,nlat_regional,grid_reverse_flag) do i=2,nlon_regional - work_bu_w(i,:)=half*(u2d(i-1,:)+u2d(i,:)) - work_bv_w(i,:)=half*(v2d(i-1,:)+v2d(i,:)) + work_bu_w(i,:,inative)=half*(u2d(i-1,:)+u2d(i,:)) + work_bv_w(i,:,inative)=half*(v2d(i-1,:)+v2d(i,:)) enddo - work_bu_w(1,:)=u2d(1,:) - work_bv_w(1,:)=v2d(1,:) - work_bu_w(nlon_regional+1,:)=u2d(nlon_regional,:) - work_bv_w(nlon_regional+1,:)=v2d(nlon_regional,:) + work_bu_w(1,:,inative)=u2d(1,:) + work_bv_w(1,:,inative)=v2d(1,:) + work_bu_w(nlon_regional+1,:,inative)=u2d(nlon_regional,:) + work_bv_w(nlon_regional+1,:,inative)=v2d(nlon_regional,:) do j=2,nlat_regional - work_bu_s(:,j)=half*(u2d(:,j-1)+u2d(:,j)) - work_bv_s(:,j)=half*(v2d(:,j-1)+v2d(:,j)) + work_bu_s(:,j,inative)=half*(u2d(:,j-1)+u2d(:,j)) + work_bv_s(:,j,inative)=half*(v2d(:,j-1)+v2d(:,j)) enddo - work_bu_s(:,1)=u2d(:,1) - work_bv_s(:,1)=v2d(:,1) - work_bu_s(:,nlat_regional+1)=u2d(:,nlat_regional) - work_bv_s(:,nlat_regional+1)=v2d(:,nlat_regional) + work_bu_s(:,1,inative)=u2d(:,1) + work_bv_s(:,1,inative)=v2d(:,1) + work_bu_s(:,nlat_regional+1,inative)=u2d(:,nlat_regional) + work_bv_s(:,nlat_regional+1,inative)=v2d(:,nlat_regional) endif - - call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) - call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) - call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) - call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) enddo ! + + call check( nf90_put_var(gfile_loc,u_wgrd_VarId,work_bu_w,start=uw_startloc,count=uw_countloc) ) + call check( nf90_put_var(gfile_loc,u_sgrd_VarId,work_bu_s,start=us_startloc,count=us_countloc) ) + call check( nf90_put_var(gfile_loc,v_wgrd_VarId,work_bv_w,start=vw_startloc,count=vw_countloc) ) + call check( nf90_put_var(gfile_loc,v_sgrd_VarId,work_bv_s,start=vs_startloc,count=vs_countloc) ) call check( nf90_close(gfile_loc) ) deallocate(work_bu_w,work_bv_w) deallocate(work_bu_s,work_bv_s) + endif !procuse + deallocate(work_au,work_av,u2d,v2d) if(add_saved) deallocate(workau2,workav2) if (allocated(workbu_w2)) then @@ -4541,8 +4636,8 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file use mod_fv3_lola, only: fv3_ll_to_h use mod_fv3_lola, only: fv3_h_to_ll use netcdf, only: nf90_open,nf90_close - use netcdf, only: nf90_write,nf90_inq_varid - use netcdf, only: nf90_put_var,nf90_get_var + use netcdf, only: nf90_write,nf90_netcdf4, nf90_mpiio,nf90_inq_varid + use netcdf, only: nf90_put_var,nf90_get_var,nf90_independent,nf90_var_par_access use netcdf, only: nf90_inquire_dimension use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_sub2grid @@ -4558,8 +4653,8 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file character(len=max_filename_length) :: filenamein2 character(len=max_varname_length) :: varname,vgsiname,name - integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) - integer(i_kind) countloc_tmp(3),startloc_tmp(3) + integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(4),startloc(4) + integer(i_kind) countloc_tmp(4),startloc_tmp(4) integer(i_kind) kbgn,kend integer(i_kind) inative,ilev,ilevtot integer(i_kind) :: VarId,gfile_loc @@ -4621,11 +4716,11 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file allocate(gfile_loc_layout(0:fv3_io_layout_y-1)) do nio=0,fv3_io_layout_y-1 write(filename_layout,'(a,a,I4.4)') trim(filenamein),'.',nio - call check( nf90_open(filename_layout,nf90_write,gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filename_layout,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc_layout(nio),comm=mpi_comm_read,info=MPI_INFO_NULL) ) enddo gfile_loc=gfile_loc_layout(0) else - call check( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) + call check( nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL) ) endif do ilevtot=kbgn,kend @@ -4637,15 +4732,14 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) nz=grd_ionouv%nsig nzp1=nz+1 inative=nzp1-ilev - countloc=(/nxcase,nycase,1/) - startloc=(/1,1,inative/) + countloc=(/nxcase,nycase,1,1/) + startloc=(/1,1,inative,1/) work_a=hwork(1,:,:,ilevtot) @@ -4654,23 +4748,24 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file if(trim(name)=='xaxis_1') nx_phy=len if( nx_phy == nxcase )then allocate(work_b_tmp(nxcase,nycase)) - countloc_tmp=(/nxcase,nycase,1/) + countloc_tmp=(/nxcase,nycase,1,1/) phy_smaller_domain = .false. else allocate(work_b_tmp(nxcase-6,nycase-6)) - countloc_tmp=(/nxcase-6,nycase-6,1/) + countloc_tmp=(/nxcase-6,nycase-6,1,1/) phy_smaller_domain = .true. end if - startloc_tmp=(/1,1,ilev/) + startloc_tmp=(/1,1,ilev,1/) end if call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_var_par_access(gfile_loc, VarId, nf90_independent)) if(index(vgsiname,"delzinc") > 0) then if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout @@ -4685,7 +4780,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file if(add_saved)then if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) call check( nf90_get_var(gfile_loc_layout(nio),VarId,work_b_layout,start = startloc, count = countloc) ) work_b(:,ny_layout_b(nio):ny_layout_e(nio))=work_b_layout @@ -4721,7 +4816,7 @@ subroutine gsi_fv3ncdf_write(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3file endif if(fv3_io_layout_y > 1) then do nio=0,fv3_io_layout_y-1 - countloc=(/nxcase,ny_layout_len(nio),1/) + countloc=(/nxcase,ny_layout_len(nio),1,1/) allocate(work_b_layout(nxcase,ny_layout_len(nio))) work_b_layout=work_b(:,ny_layout_b(nio):ny_layout_e(nio)) call check( nf90_put_var(gfile_loc_layout(nio),VarId,work_b_layout, start = startloc, count = countloc) ) @@ -4795,12 +4890,13 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f ! !$$$ end documentation block - use mpimod, only: mpi_rtype,mpi_comm_world,mype,mpi_info_null + use mpimod, only: npe, setcomm,mpi_integer,mpi_max,mpi_rtype,mpi_comm_world,mype,mpi_info_null use mod_fv3_lola, only: fv3_ll_to_h use mod_fv3_lola, only: fv3_h_to_ll use netcdf, only: nf90_open,nf90_close - use netcdf, only: nf90_write,nf90_inq_varid + use netcdf, only: nf90_write, nf90_netcdf4,nf90_mpiio,nf90_inq_varid use netcdf, only: nf90_put_var,nf90_get_var + use netcdf, only: nf90_independent,nf90_var_par_access use gsi_bundlemod, only: gsi_bundle use general_sub2grid_mod, only: sub2grid_info,general_sub2grid implicit none @@ -4824,6 +4920,10 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f character(len=max_varname_length) :: varname,vgsiname integer(i_kind) nlatcase,nloncase,nxcase,nycase,countloc(3),startloc(3) + integer(i_kind):: iworld,iworld_group,nread,mpi_comm_read,i,ierror + integer(i_kind),dimension(npe):: members,members_read,mype_read_rank + logical:: procuse + mm1=mype+1 nloncase=grd_ionouv%nlon @@ -4838,7 +4938,30 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f allocate( work_b(nlon_regional,nlat_regional)) allocate( workb2(nlon_regional,nlat_regional)) allocate( worka2(nlatcase,nloncase)) - call check ( nf90_open(filenamein,nf90_write,gfile_loc,comm=mpi_comm_world,info=MPI_INFO_NULL)) !clt + + procuse = .false. + members=-1 + members_read=-1 + if (kbgn<=kend) then + procuse = .true. + members(mm1) = mype + endif + + call mpi_allreduce(members,members_read,npe,mpi_integer,mpi_max,mpi_comm_world,ierror) + + nread=0 + mype_read_rank=-1 + do i=1,npe + if (members_read(i) >= 0) then + nread=nread+1 + mype_read_rank(nread) = members_read(i) + endif + enddo + + call setcomm(iworld,iworld_group,nread,mype_read_rank,mpi_comm_read,ierror) + + if (procuse) then + call check ( nf90_open(filenamein,ior(nf90_netcdf4,ior(nf90_write, nf90_mpiio)),gfile_loc,comm=mpi_comm_read,info=MPI_INFO_NULL)) !clt do ilevtot=kbgn,kend vgsiname=grd_ionouv%names(1,ilevtot) if(trim(vgsiname)=='amassi') cycle @@ -4848,7 +4971,6 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f call getfv3lamfilevname(vgsiname,fv3filenamegin,filenamein2,varname) if(trim(filenamein) /= trim(filenamein2)) then write(6,*)'filenamein and filenamein2 are not the same as expected, stop' - call flush(6) call stop2(333) endif ilev=grd_ionouv%lnames(1,ilevtot) @@ -4862,6 +4984,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f call check( nf90_inq_varid(gfile_loc,trim(varname),VarId) ) + call check( nf90_var_par_access(gfile_loc, VarId, nf90_independent)) call check( nf90_get_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) ) if(index(vgsiname,"delzinc") > 0) then write(6,*)'delz is not in the cold start fiels with this option, incompatible setup , stop' @@ -4885,6 +5008,7 @@ subroutine gsi_fv3ncdf_write_v1(grd_ionouv,cstate_nouv,add_saved,filenamein,fv3f call check( nf90_put_var(gfile_loc,VarId,work_b,start=startloc,count=countloc) ) enddo !ilevtot call check(nf90_close(gfile_loc)) + endif deallocate(work_b,work_a) deallocate(worka2,workb2) @@ -5420,7 +5544,7 @@ subroutine gsi_copy_bundle(bundi,bundo) character(len=max_varname_length),dimension(:),allocatable:: target_name_vars3d character(len=max_varname_length) ::varname real(r_kind),dimension(:,:,:),pointer:: pvar3d=>NULL() - real(r_kind),dimension(:,:,:),pointer:: pvar2d =>NULL() + real(r_kind),dimension(:,:),pointer:: pvar2d =>NULL() integer(i_kind):: src_nc3d,src_nc2d,target_nc3d,target_nc2d integer(i_kind):: ivar,jvar,istatus src_nc3d=bundi%n3d diff --git a/ush/sub_hera b/ush/sub_hera index 610756af00..c94b734596 100755 --- a/ush/sub_hera +++ b/ush/sub_hera @@ -120,10 +120,10 @@ echo "#SBATCH --output=$output" echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile #echo "#SBATCH -j oe" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile -echo "#SBATCH --mem=0" >> $cfile +#cltorg echo "#SBATCH --mem=0" >> $cfile #echo "#SBATCH -V" >> $cfile #echo "#PBS -d" >> $cfile #. $exec >> $cfile @@ -143,7 +143,6 @@ echo "module list" >> $cfile echo "" >>$cfile cat $exec >> $cfile - if [[ $nosub = YES ]];then cat $cfile exit diff --git a/ush/sub_hercules b/ush/sub_hercules index 459b480559..78a0f5daee 100755 --- a/ush/sub_hercules +++ b/ush/sub_hercules @@ -111,7 +111,7 @@ echo "#SBATCH --job-name=$jobname" echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --partition=$partition" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "" >>$cfile @@ -131,7 +131,7 @@ echo "module use $modulefiles" >> $cfile echo "module load gsi_hercules.intel" >> $cfile #TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Hercules echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile -echo "" >> $cfile + cat $exec >> $cfile if [[ $nosub = YES ]];then diff --git a/ush/sub_jet b/ush/sub_jet index 9bd60486f6..96f3eae9b2 100755 --- a/ush/sub_jet +++ b/ush/sub_jet @@ -108,7 +108,7 @@ echo "#SBATCH --output=$output" echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "#SBATCH --mem=0" >> $cfile echo "#SBATCH --partition=kjet" >> $cfile diff --git a/ush/sub_orion b/ush/sub_orion index 5a13f54845..b810576379 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -111,7 +111,7 @@ echo "#SBATCH --job-name=$jobname" echo "#SBATCH --qos=$queue" >> $cfile echo "#SBATCH --partition=$partition" >> $cfile echo "#SBATCH --time=$timew" >> $cfile -echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile +echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "" >>$cfile From f7e93abf1ff19f27aae148c74fd3d6561e49c117 Mon Sep 17 00:00:00 2001 From: TingLei-NOAA <63461756+TingLei-NOAA@users.noreply.github.com> Date: Sun, 24 Mar 2024 17:21:10 -0400 Subject: [PATCH 16/35] GSI built with debug mode failed in the global_4densvar (#722) Co-authored-by: Tinglei-daprediction --- .../cmake/gsiapp_compiler_flags_Intel_Fortran.cmake | 2 +- src/gsi/intjcmod.f90 | 2 +- src/gsi/read_nsstbufr.f90 | 12 ++++++------ 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake b/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake index 8ba2887da8..b1d28132dc 100644 --- a/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake +++ b/src/gsi/cmake/gsiapp_compiler_flags_Intel_Fortran.cmake @@ -14,7 +14,7 @@ set(CMAKE_Fortran_FLAGS_RELEASE "-O3 -fp-model strict") # DEBUG FLAGS #################################################################### -set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -fp-model source -debug -ftrapuv -warn all,nointerfaces -check all,noarg_temp_created -fp-stack-check -fstack-protector") +set(CMAKE_Fortran_FLAGS_DEBUG "-O0 -init=snan,arrays -fp-model source -debug -ftrapuv -warn all,nointerfaces -check all,noarg_temp_created -fp-stack-check -fstack-protector") #################################################################### # LINK FLAGS diff --git a/src/gsi/intjcmod.f90 b/src/gsi/intjcmod.f90 index 4b149da6b9..a3af642111 100644 --- a/src/gsi/intjcmod.f90 +++ b/src/gsi/intjcmod.f90 @@ -103,7 +103,7 @@ subroutine intlimq(rval,sval,itbin) call gsi_bundlegetpointer(gsi_metguess_bundle(itbin),'q',ges_q_it,ier) if(ier/=0)return -!$omp parallel do schedule(dynamic,1) private(k,j,i,q) +!$omp parallel do schedule(dynamic,1) private(k,j,i,ii,q) do k = 1,nsig do j = 2,lon1+1 do i = 2,lat1+1 diff --git a/src/gsi/read_nsstbufr.f90 b/src/gsi/read_nsstbufr.f90 index f287dbd0b8..97096f3760 100644 --- a/src/gsi/read_nsstbufr.f90 +++ b/src/gsi/read_nsstbufr.f90 @@ -542,9 +542,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & kx = 197 sstoe = one elseif ( trim(subset) == 'NC031002' ) then ! TESAC - if ( tpf(1,1) >= one .and. tpf(1,1) < 20.0_r_kind ) then - zob = tpf(1,1) - elseif ( tpf(1,1) >= zero .and. tpf(1,1) < one ) then + if ( tpf2(1,1) >= one .and. tpf2(1,1) < 20.0_r_kind ) then + zob = tpf2(1,1) + elseif ( tpf2(1,1) >= zero .and. tpf2(1,1) < one ) then zob = one endif kx = 198 @@ -553,9 +553,9 @@ subroutine read_nsstbufr(nread,ndata,nodata,gstime,infile,obstype,lunout, & kx = 199 ! classify argo & glider to be bathy type sstoe = r0_6 elseif ( trim(subset) == 'NC031001' ) then ! BATHY - if ( tpf(1,1) >= one .and. tpf(1,1) <= 20.0_r_kind ) then - zob = tpf(1,1) - elseif ( tpf(1,1) >= zero .and. tpf(1,1) < one ) then + if ( tpf2(1,1) >= one .and. tpf2(1,1) <= 20.0_r_kind ) then + zob = tpf2(1,1) + elseif ( tpf2(1,1) >= zero .and. tpf2(1,1) < one ) then zob = one endif kx = 199 From 1cc934edaaa77bd3eee51744f1cf81810d52e2c0 Mon Sep 17 00:00:00 2001 From: shoyokota <103961291+shoyokota@users.noreply.github.com> Date: Tue, 26 Mar 2024 07:07:28 -0400 Subject: [PATCH 17/35] Add the Multigrid Beta Filter (MGBF) for ensemble localization (#699) (#700) **DUE DATE for merger of this PR into `develop` is 3/29/2024 (six weeks after PR creation).** **Description** Resolves #699 This PR is to add the option to apply Multigrid Beta Filter (MGBF; [Purser et al. 2022](https://doi.org/10.1175/MWR-D-20-0405.1)) for ensemble localization instead of Recursive Filter (RF). This work includes to add an initial version of the MGBF as a subdirectory in GSI. To apply the MGBF, set "l_mgbf_loc=true" in the namelist and additionally input "mgbf_loc01.nml". (In Scale/Variable-Dependent Localization, input also "mgbf_locXX.nml" (XX=02,03,...) with the same number of grid points.)
**How to set MGBF parameters in mgbf_locXX.nml** An example of mgbf_locXX.nml is as follows: ``` &PARAMETERS_MGBETA mg_ampl01=1.125, ! length of vertical beta filter (standard deviation; filter grid unit) mg_ampl02=2.4, ! length of horizontal beta filter (standard deviation; filter grid unit) mg_ampl03=0.85, ! length of 3D beta filter (standard deviation; filter grid unit) mg_weig1=0., ! weight of generation 1 mg_weig2=0., ! weight of generation 2 mg_weig3=0., ! weight of generation 3 mg_weig4=1., ! weight of generation 4 hx=5, ! number of halo grid points in x-direction hy=5, ! number of halo grid points in y-direction hz=3, ! number of halo grid points in z-direction p=2, ! beta filter exponent mgbf_line=.false., ! set false except for mgbf_proc=2,4,7 mgbf_proc=8, ! 1-2: 3D filter; 3-5: 2D filter for static B; 6-8: 2D filter for localization (1,3,6: radial filter; 2,4,7: line filter; 5,8: isotropic line filter) lm_a=65, ! number of vertical layers in analysis grid lm=33, ! number of vertical layers in filter grid km2=0, ! number of 2D variables (set 0 for localization) km3=1, ! number of 3D variables (set 1 for localization) n_ens=30, ! ensemble size l_loc=.true., ! set true in localization l_filt_g1=.false., ! set false in skipping generation 1 l_lin_vertical=.true., ! set true in applying linear vertical interpolation for analysis-filter mapping l_lin_horizontal=.true., ! set true in applying linear horizontal interpolation for analysis-filter mapping l_quad_horizontal=.false., ! set true in applying quadratic horizontal interpolation for analysis-filter mapping l_new_map=.true., ! set true in applying efficient vertical interpolation for analysis-filter mapping l_vertical_filter=.true., ! set true in applying vertical beta filter outside 2D filter ldelta=.false., ! (not used) lquart=.false., ! set true in applying quadratic horizontal interpolation for up/down-sending lhelm=.false., ! set true in applying Helmholtz differential operator for weighting nm0=1975, ! number of analysis grid points in x-direction mm0=1350, ! number of analysis grid points in y-direction gm_max=4, ! highest generation (max: 4) nxPE=79, ! number of MPI processors in x-direction nyPE=54, ! number of MPI processors in y-direction im_filt=8, ! number of filter grid points in each MPI processor in x-direction jm_filt=8, ! number of filter grid points in each MPI processor in y-direction / ``` Here, to make the result of MGBF-based localization similar to RF-based one, we can set the beta filter length ( mg_ampl0[12] ) from the recursive filter length in the GSI namelist ( s_ens_[vh] ) as: - $\text{mg\\_ampl01} = \left[\text{s\\_ens\\_v (grid unit)} * \frac{1}{\sqrt{2}} * \frac{\text{lm}-1}{\text{lm\\_a}-1} \right]^2$ - $\text{mg\\_ampl02} = \left[\frac{\text{s\\_ens\\_h (km)}}{\text{analysis grid interval (km)}} * \frac{1}{\sqrt{2}} * \frac{\text{im\\_filt} * \text{nxPE}}{\text{nm0}} * \frac{1}{2} * \frac{1}{2} * \frac{1}{2} \right]^2$ (in case mg_weig[1-4]=[0,0,0,1]) Please note there are some limitations for the other MGBF parameters such as: - The number of MPI processors input in GSI should be nxPE x nyPE - (nm0, mm0, lm_a) should be the same as the GSI analysis grid - nm0 should be divisible by nxPE - mm0 should be divisible by nyPE - nm0 / nxPE = mm0 / nyPE
**How to run RRFS regression tests with MGBF-based localization** Change settings in regression/ as follows, and run Test#3 (rrfs_3denvar_glbens) ```diff diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 7ca183ef3..671d028ff 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -457,7 +457,7 @@ OBS_INPUT:: beta_s0=0.15,s_ens_h=110,s_ens_v=3, regional_ensemble_option=1, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 5.1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, @@ -465,6 +465,7 @@ OBS_INPUT:: fv3sar_bg_opt=0, readin_localization=.true., ens_fast_read=.false., + l_mgbf_loc=.true., / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, ``` ```diff diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index e03917e88..36b8b6a22 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -438,7 +438,7 @@ OBS_INPUT:: beta_s0=0.15,s_ens_h=110,s_ens_v=3, regional_ensemble_option=1, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 5.1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, @@ -446,6 +446,7 @@ OBS_INPUT:: fv3sar_bg_opt=0, readin_localization=.true., ens_fast_read=.false., + l_mgbf_loc=.true., / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, ``` ```diff diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 2ac615fc4..6186acdbb 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -87,23 +87,23 @@ case $regtest in rrfs_3denvar_glbens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="30/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="15/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="30/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="15/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/2" + topts[1]="0:15:00" ; popts[1]="30/2/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="15/4/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then - topts[1]="0:15:00" ; popts[1]="20/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="20/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="15/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/6/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="15/4/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="10/6/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="60/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="30/2/" ; ropts[2]="/1" fi if [ "$debug" = ".true." ] ; then ``` ```diff diff --git a/regression/rrfs_3denvar_glbens.sh b/regression/rrfs_3denvar_glbens.sh index af5da5117..04fd73d57 100755 --- a/regression/rrfs_3denvar_glbens.sh +++ b/regression/rrfs_3denvar_glbens.sh @@ -272,6 +272,46 @@ $gsi_namelist EOF +cat << EOF > mgbf_loc01.nml +&PARAMETERS_MGBETA + mg_ampl01=1.125, ! length of vertical beta filter (standard deviation; filter grid unit) + mg_ampl02=1.615, ! length of horizontal beta filter (standard deviation; filter grid unit) + mg_ampl03=0.85, ! length of 3D beta filter (standard deviation; filter grid unit) + mg_weig1=0., ! weight of generation 1 + mg_weig2=1., ! weight of generation 2 + mg_weig3=0., ! weight of generation 3 + mg_weig4=0., ! weight of generation 4 + hx=4, ! number of halo grid points in x-direction + hy=4, ! number of halo grid points in y-direction + hz=3, ! number of halo grid points in z-direction + p=2, ! beta filter exponent + mgbf_line=.false., ! set false except for mgbf_proc=2,4,7 + mgbf_proc=8, ! 1-2: 3D filter; 3-5: 2D filter for static B; 6-8: 2D filter for localization (1,3,6: radial filter; 2,4,7: line filter; 5,8: isotropic line filter) + lm_a=65, ! number of vertical layers in analysis grid + lm=33, ! number of vertical layers in filter grid + km2=0, ! number of 2D variables (set 0 for localization) + km3=1, ! number of 3D variables (set 1 for localization) + n_ens=10, ! ensemble size + l_loc=.true., ! set true in localization + l_filt_g1=.false., ! set false in skipping generation 1 + l_lin_vertical=.true., ! set true in applying linear vertical interpolation for analysis-filter mapping + l_lin_horizontal=.true., ! set true in applying linear horizontal interpolation for analysis-filter mapping + l_quad_horizontal=.false., ! set true in applying quadratic horizontal interpolation for analysis-filter mapping + l_new_map=.true., ! set true in applying efficient vertical interpolation for analysis-filter mapping + l_vertical_filter=.true., ! set true in applying vertical beta filter outside 2D filter + ldelta=.false., ! (not used) + lquart=.false., ! set true in applying quadratic horizontal interpolation for up/down-sending + lhelm=.false., ! set true in applying Helmholtz differential operator for weighting + nm0=40, ! number of analysis grid points in x-direction + mm0=24, ! number of analysis grid points in y-direction + gm_max=2, ! highest generation (max: 4) + nxPE=10, ! number of MPI processors in x-direction + nyPE=6, ! number of MPI processors in y-direction + im_filt=4, ! number of filter grid points in each MPI processor in x-direction + jm_filt=4, ! number of filter grid points in each MPI processor in y-direction + / +EOF + # Copy executable and fixed files to $tmpdir if [[ $exp == *"updat"* ]]; then $ncp $gsiexec_updat ./gsi.x ```
**Type of change** Please delete options that are not relevant. - [ ] Bug fix (non-breaking change which fixes an issue) - [x] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) - [ ] This change requires a documentation update **How Has This Been Tested?** EnVar for NA-domain RRFS was tested with "mgbf_locXX.nml" (XX=01) shown above on Orion. The resulting analysis increment was similar to the original and the computation time for localization became short. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes - [x] Any dependent changes have been merged and published Co-authored-by: Sho Yokota --- CMakeLists.txt | 2 + INSTALL.md | 1 + src/CMakeLists.txt | 5 + src/gsi/CMakeLists.txt | 15 + src/gsi/gsimod.F90 | 18 +- src/gsi/hybrid_ensemble_isotropic.F90 | 515 +- 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 | 972 +++ src/mgbf/mg_intstate.f90 | 1394 ++++ src/mgbf/mg_mppstuff.f90 | 190 + src/mgbf/mg_parameter.f90 | 936 +++ src/mgbf/mg_timers.f90 | 218 + src/mgbf/mg_transfer.f90 | 499 ++ 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, 26816 insertions(+), 141 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..8a1ce896bb 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 ): @@ -1985,6 +1987,18 @@ subroutine gsimain_initialize regional=wrf_nmm_regional.or.wrf_mass_regional.or.twodvar_regional.or.nems_nmmb_regional .or. cmaq_regional regional=regional.or.fv3_regional.or.fv3_cmaq_regional +! Force turn off MGBF-based localization except for regional application + if(.not.regional.and.l_mgbf_loc) then + l_mgbf_loc=.false. + if(mype==0) write(6,*)'GSIMOD: for global app, l_mgbf_loc is not applicable, reset l_mgbf_loc=',l_mgbf_loc + end if + +! Force turn off MGBF-based localization for lsqrtb=.true. + if(lsqrtb.and.l_mgbf_loc) then + l_mgbf_loc=.false. + if(mype==0) write(6,*)'GSIMOD: for lsqrtb=.true., l_mgbf_loc is not applicable, reset l_mgbf_loc=',l_mgbf_loc + end if + ! Currently only able to have use_gfs_stratosphere=.true. for nems_nmmb_regional=.true. use_gfs_stratosphere=use_gfs_stratosphere.and.(nems_nmmb_regional.or.wrf_nmm_regional) if(mype==0) write(6,*) 'in gsimod: use_gfs_stratosphere,nems_nmmb_regional,wrf_nmm_regional= ', & diff --git a/src/gsi/hybrid_ensemble_isotropic.F90 b/src/gsi/hybrid_ensemble_isotropic.F90 index 05b3845627..87f3605eaf 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 @@ -174,6 +179,12 @@ module hybrid_ensemble_isotropic real(r_kind),allocatable,dimension(:,:,:) :: spectral_filter,sqrt_spectral_filter integer(i_kind),allocatable,dimension(:) :: k_index + integer(r_kind) :: nval_loc_en + +! For MGBF + type (mg_intstate_type), allocatable, dimension(:) :: obj_mgbf + real(r_kind), allocatable, dimension(:,:,:) :: work_mgbf + ! following is for special subdomain to slab variables used when internally generating ensemble members integer(i_kind) nval2f,nscl @@ -183,7 +194,6 @@ module hybrid_ensemble_isotropic logical,parameter:: debug=.false. - contains subroutine init_rf_z(z_len) @@ -1732,6 +1742,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 +1761,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 @@ -3608,7 +3620,6 @@ subroutine bkerror_a_en(grady) use hybrid_ensemble_parameters, only: n_ens use hybrid_ensemble_parameters, only: naensgrp use hybrid_ensemble_parameters, only: alphacvarsclgrpmat - use hybrid_ensemble_parameters, only: nval_lenz_en use gsi_bundlemod,only: gsi_bundlegetpointer implicit none @@ -3639,8 +3650,8 @@ subroutine bkerror_a_en(grady) call bkgcov_a_en_new_factorization(1,grady%aens(ii,1,1:n_ens)) end do else - allocate(z(nval_lenz_en,naensgrp)) - allocate(z2(nval_lenz_en)) + allocate(z(nval_loc_en,naensgrp)) + allocate(z2(nval_loc_en)) do ii=1,nsubwin do ig=1,naensgrp call ckgcov_a_en_new_factorization_ad(ig,z(1,ig),grady%aens(ii,ig,1:n_ens)) @@ -3648,7 +3659,7 @@ subroutine bkerror_a_en(grady) do ig=1,naensgrp z2=zero do ig2=1,naensgrp - do k=1,nval_lenz_en + do k=1,nval_loc_en z2(k) = z2(k) + z(k,ig2) * alphacvarsclgrpmat(ig,ig2) enddo enddo @@ -3699,9 +3710,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,naensgrp 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 @@ -3717,54 +3730,101 @@ subroutine bkgcov_a_en_new_factorization(ig,a_en) ipnt=1 +! MGBF-based localization (now available only in regional=.true.) +! (Note that MGBF is applied only in ig<=naensgrp +! because recursive filter is applied for ig>naensgrp +! to separate scales for scale-dependent localization +! even in MGBF-based localization) + if(l_mgbf_loc.and.ig<=naensgrp) then + +! Apply vertical smoother on each ensemble member + allocate(work_mgbf(obj_mgbf(1)%km_a_all,obj_mgbf(1)%nm,obj_mgbf(1)%mm)) + work_mgbf=zero + iadvance=1 ; iback=2 +!$omp parallel do schedule(static,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,1) + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,1) + enddo + +! Mapping from analysis grid to filter grid + call obj_mgbf(1)%anal_to_filt_allmap(work_mgbf) + +! Apply horizontal smoother for number of horizontal scales + call obj_mgbf(1)%filtering_procedure(obj_mgbf(1)%mgbf_proc,0) + +! Mapping from filter grid to analysis grid + call obj_mgbf(1)%filt_to_anal_allmap(work_mgbf) + +! 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)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,1) + if(.not.obj_mgbf(1)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,1) + enddo + deallocate(work_mgbf) + +! Recursive/Spectral filter-based localization(ig<=naensgrp) +! or scale-separation(ig>naensgrp) + else + ! Apply vertical smoother on each ensemble member ! 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) - endif - iadvance=1 ; iback=2 + 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(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 + 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) + 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) - else - call sf_xy(ig,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) - end if + 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) + else + 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) ! Retrieve ensemble components from long vector ! Apply vertical smoother on each ensemble member - iadvance=2 ; iback=1 + 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) + 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 @@ -3796,7 +3856,7 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) use constants, only: zero 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 @@ -3806,17 +3866,23 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) ! Passed Variables integer(i_kind),intent(in ) :: ig type(gsi_bundle),intent(inout) :: a_en(n_ens) - real(r_kind),dimension(nval_lenz_en),intent(in ) :: z + real(r_kind),dimension(nval_loc_en),intent(in ) :: z +!NOTE: +! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor. +! In MGBF-based localization, it is horizontally-local and vertically-global as +! nval_loc_en = nhoriz * obj_mgbf(ig)%km_all +! and nhoriz = ( obj_mgbf(ig)%im + obj_mgbf(ig)%hx*2 ) * ( obj_mgbf(ig)%jm + obj_mgbf(ig)%hy*2 ) +! In recursive/spectral filter-based localization, it is horizontally-global and vertically-local as +! nval_loc_en = nhoriz * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! and nhoriz = grd_loc%nlat * grd_loc%nlon (for regional recursive filter) +! nhoriz = ( sp_loc%jcap+1 ) * ( sp_loc%jcap+2 ) (for global spectral filter) +! but internal array hwork always has +! dimension grd_loc%nlat * grd_loc%nlon * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! which would be used as nval_loc_en when the recursive filter is used. ! 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 real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) -!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 -! but internal array hwork always has -! dimension grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) -! which just happens to match up with nval_lenz_en for regional case, but not global. real(r_kind),allocatable,dimension(:):: a_en_work call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) @@ -3825,54 +3891,90 @@ subroutine ckgcov_a_en_new_factorization(ig,z,a_en) call stop2(999) endif +! MGBF-based localization (now available only in regional=.true.) + if(l_mgbf_loc) then + +! Apply horizontal smoother for number of horizontal scales + 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) + +! Mapping from filter grid to analysis grid + allocate(work_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)) + work_mgbf=zero + call obj_mgbf(ig)%filt_to_anal_allmap(work_mgbf) - if(grd_loc%kend_loc+1-grd_loc%kbegin_loc==0) then +! 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)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,ig) + if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + enddo + deallocate(work_mgbf) + +! Recursive/Spectral filter-based localization + else + + 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 ! grd_loc%kend_alloc = grd_loc%kbegin_loc in this case, so set to zero. - hwork=zero - else + hwork=zero + else ! Apply horizontal smoother for number of horizontal scales - if(regional) then + if(regional) then ! 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) - else + 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) + else #ifdef LATER - call sqrt_sf_xy(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) + 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"' + write(6,*) ' problem with ibm compiler with "use hybrid_ensemble_isotropic, only: sqrt_sf_xy"' #endif /*LATER*/ + end if 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) + 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) + 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 + iadvance=2 ; iback=1 !$omp parallel do schedule(static,1) private(k) - do k=1,n_ens + do k=1,n_ens - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - enddo + enddo + + endif return end subroutine ckgcov_a_en_new_factorization @@ -3909,7 +4011,7 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) use constants, only: zero 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 @@ -3919,17 +4021,23 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) ! Passed Variables integer(i_kind),intent(in ) :: ig type(gsi_bundle),intent(inout) :: a_en(n_ens) - real(r_kind),dimension(nval_lenz_en),intent(inout) :: z + real(r_kind),dimension(nval_loc_en),intent(inout) :: z +!NOTE: +! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor. +! In MGBF-based localization, it is horizontally-local and vertically-global as +! nval_loc_en = nhoriz * obj_mgbf(ig)%km_all +! and nhoriz = ( obj_mgbf(ig)%im + obj_mgbf(ig)%hx*2 ) * ( obj_mgbf(ig)%jm + obj_mgbf(ig)%hy*2 ) +! In recursive/spectral filter-based localization, it is horizontally-global and vertically-local as +! nval_loc_en = nhoriz * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! and nhoriz = grd_loc%nlat * grd_loc%nlon (for regional recursive filter) +! nhoriz = ( sp_loc%jcap+1 ) * ( sp_loc%jcap+2 ) (for global spectral filter) +! but internal array hwork always has +! dimension grd_loc%nlat * grd_loc%nlon * ( grd_loc%kend_alloc - grd_loc%kbegin_loc + 1 ) +! which would be used as nval_loc_en when the recursive filter is used. ! 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 real(r_kind) hwork(grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1)) -!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 -! but internal array hwork always has -! dimension grd_loc%nlat*grd_loc%nlon*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) -! which just happens to match up with nval_lenz_en for regional case, but not global. real(r_kind),allocatable,dimension(:):: a_en_work call gsi_bundlegetpointer(a_en(1),'a_en',ipnt,istatus) @@ -3938,53 +4046,159 @@ subroutine ckgcov_a_en_new_factorization_ad(ig,z,a_en) call stop2(999) endif +! MGBF-based localization (now available only in regional=.true.) + if(l_mgbf_loc) then + ! Apply vertical smoother on each ensemble member - iadvance=1 ; iback=2 + allocate(work_mgbf(obj_mgbf(ig)%km_a_all,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm)) + work_mgbf=zero + iadvance=1 ; iback=2 +!$omp parallel do schedule(static,1) private(k,ii,is,ie) + do k=1,n_ens + ii=(k-1)*grd_loc%nsig + is=ii+1 + ie=ii+grd_loc%nsig + if(.not.obj_mgbf(ig)%l_vertical_filter) call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + call map_work_mgbf(a_en(k)%r3(ipnt)%q,work_mgbf(is:ie,:,:),iadvance,ig) + enddo + +! Mapping from analysis grid to filter grid + call obj_mgbf(ig)%anal_to_filt_allmap(work_mgbf) + deallocate(work_mgbf) + +! Apply horizontal smoother for number of horizontal scales + 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 + +! Recursive/Spectral filter-based localization + else + +! Apply vertical smoother on each ensemble member + iadvance=1 ; iback=2 !$omp parallel do schedule(static,1) private(k) - do k=1,n_ens + do k=1,n_ens - call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) - - enddo + call new_factorization_rf_z(a_en(k)%r3(ipnt)%q,iadvance,iback,ig) + + enddo ! 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) - 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 + 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 + 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) + 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 + 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 ! grd_loc%kend_alloc = grd_loc%kbegin_loc in this case, so set to zero. - z=zero - 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 + z=zero else - call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) +! 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 + else + call sqrt_sf_xy_ad(ig,z,hwork,grd_loc%kbegin_loc,grd_loc%kend_loc) + end if end if - end if + + endif return end subroutine ckgcov_a_en_new_factorization_ad +subroutine map_work_mgbf(f,g,iadvance,ig) +!$$$ subprogram documentation block +! . . . +! subprogram: map_work_mgbf +! prgrmmr: yokota org: NCEP/EMC date: 2024-02-20 +! +! abstract: mapping field for MGBF +! +! program history log: +! +! input argument list: +! f - field to be filtered +! g - field for MGBF +! iadvance - =1 to map from f to g, =2 to map from g to f +! ig - number for smoothing scales +! +! output argument list: +! f - field to be filtered +! g - field for MGBF +! +! attributes: +! language: f90 +! machine: ibm RS/6000 SP +! +!$$$ end documentation block + + use constants, only: zero + use hybrid_ensemble_parameters, only: grd_loc + implicit none + + integer(i_kind),intent(in ) :: iadvance,ig + real(r_kind) ,intent(inout) :: f(grd_loc%lat2,grd_loc%lon2,grd_loc%nsig) + real(r_kind) ,intent(inout) :: g(grd_loc%nsig,obj_mgbf(ig)%nm,obj_mgbf(ig)%mm) + + real(r_kind) :: work_tmp(grd_loc%lon2,grd_loc%lat2) + integer(i_kind) i,j,k + + if(iadvance == 1) then + do k=1,grd_loc%nsig + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + work_tmp(i,j)=f(j,i,k) + enddo + enddo + do j=1,obj_mgbf(ig)%mm + do i=1,obj_mgbf(ig)%nm + g(k,i,j)=work_tmp(i+1,j+1) + enddo + enddo + enddo + elseif(iadvance == 2) then + do k=1,grd_loc%nsig + work_tmp=zero + do j=1,obj_mgbf(ig)%mm + do i=1,obj_mgbf(ig)%nm + work_tmp(i+1,j+1)=g(k,i,j) + enddo + enddo + do j=1,grd_loc%lat2 + do i=1,grd_loc%lon2 + f(j,i,k)=work_tmp(i,j) + enddo + enddo + enddo + endif + return + +end subroutine map_work_mgbf + ! ------------------------------------------------------------------------------ ! ------------------------------------------------------------------------------ @@ -4202,6 +4416,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 +4436,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 +4538,41 @@ 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) + ! Even for MGBF-localization, recursive filter is applied for scale-separation + ! in scale-dependent localization, so init_rf_[xy] should be called in nsclgrp>1 + 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 @@ -4537,6 +4764,16 @@ subroutine hybens_localization_setup else nval_lenz_en = sp_loc%nc*(grd_loc%kend_alloc-grd_loc%kbegin_loc+1) endif + ! nval_loc_en is the number of horizontally-filtered variables in the domain of each processor, + ! which is the same as nval_lenz_en (horizontally-global and vertically-local) in recursive/spectral filter + ! but horizontally-local and vertically-global in MGBF. + if ( l_mgbf_loc ) then + nval_loc_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_loc_en = nval_lenz_en + endif ! setup vertical weighting for ensemble contribution to psfc call setup_pwgt 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..5346792581 --- /dev/null +++ b/src/mgbf/mg_interpolate.f90 @@ -0,0 +1,972 @@ +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 +!----------------------------------------------------------------------- + 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_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 +!----------------------------------------------------------------------- +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_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 +!----------------------------------------------------------------------- + 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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- + 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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- + 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 +!----------------------------------------------------------------------- +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. + + 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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- + 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 +!----------------------------------------------------------------------- +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. + + 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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- + 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 +!----------------------------------------------------------------------- +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. + + 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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- + 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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- +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 +!----------------------------------------------------------------------- +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..932084c705 --- /dev/null +++ b/src/mgbf/mg_intstate.f90 @@ -0,0 +1,1394 @@ +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_allmap,filt_to_anal_allmap + 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_allmap(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_allmap(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_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..f08b87aab3 --- /dev/null +++ b/src/mgbf/mg_parameter.f90 @@ -0,0 +1,936 @@ +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 !1-2: 3D filter (1: radial, 2: line) + !3-5: 2D filter for static B (3: radial, 4: line, 5: isotropic line) + !6-8: 2D filter for localization (6: radial, 7: line, 8: isotropic line) +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..5f929c0243 --- /dev/null +++ b/src/mgbf/mg_transfer.f90 @@ -0,0 +1,499 @@ +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_allmap - +! filt_to_anal_allmap - +! 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_allmap(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) +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +if(km_a_all==km_all.and.nm==im.and.mm==jm) then + VALL=0. + VALL(1:km_all,1:im,1:jm)=WORKA +elseif(l_new_map) then + call this%anal_to_filt_all2(WORKA) +else + call this%anal_to_filt_all(WORKA) +endif +!---------------------------------------------------------------------- +endsubroutine anal_to_filt_allmap + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +module subroutine filt_to_anal_allmap(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) +include "type_parameter_locpointer.inc" +include "type_intstat_locpointer.inc" +include "type_parameter_point2this.inc" +include "type_intstat_point2this.inc" +!---------------------------------------------------------------------- +if(km_a_all==km_all.and.nm==im.and.mm==jm) then + WORKA=VALL(1:km_all,1:im,1:jm) + VALL=0. +elseif(l_new_map) then + call this%filt_to_anal_all2(WORKA) +else + call this%filt_to_anal_all(WORKA) +endif +!---------------------------------------------------------------------- +endsubroutine filt_to_anal_allmap + +!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& +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 From 6d9ebbb7896b92a93959ce63c7a1ad9e9a0aab4f Mon Sep 17 00:00:00 2001 From: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Date: Tue, 26 Mar 2024 15:41:59 -0400 Subject: [PATCH 18/35] Dsfcalc fix (#727) Tiny fix to allow modelling of sub-fov variability for NOAA-21 ATMS. --- regression/regression_namelists.sh | 2 +- src/gsi/calc_fov_crosstrk.f90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 7ca183ef3e..552bc1ba59 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -181,7 +181,7 @@ OBS_INPUT:: sstviirs viirs-m j1 viirs-m_j1 0.0 4 0 abibufr abi g18 abi_g18 0.0 1 0 ahibufr ahi himawari9 ahi_himawari9 0.0 1 0 - atmsbufr atms n21 atms_n21 0.0 1 0 + atmsbufr atms n21 atms_n21 0.0 1 1 crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 1 0 sstviirs viirs-m j2 viirs-m_j2 0.0 4 0 ompsnpbufr ompsnp n21 ompsnp_n21 0.0 0 0 diff --git a/src/gsi/calc_fov_crosstrk.f90 b/src/gsi/calc_fov_crosstrk.f90 index dc9767e850..6cb817b56b 100644 --- a/src/gsi/calc_fov_crosstrk.f90 +++ b/src/gsi/calc_fov_crosstrk.f90 @@ -1287,7 +1287,7 @@ subroutine get_sat_height(satid, height, valid) height=866._r_kind case('npp') height=840._r_kind - case('n20') + case('n20', 'n21', 'n22', 'n23') height=840._r_kind case default write(6,*) 'GET_SAT_HEIGHT: ERROR, unrecognized satellite id: ', trim(satid) From b53740a7bd1cc416f634589075b8c8b89f0ef761 Mon Sep 17 00:00:00 2001 From: Xu Lu Date: Tue, 26 Mar 2024 21:46:08 -0400 Subject: [PATCH 19/35] Fix HAFS GSI debug build and run issues (#679) **DUE DATE for merger of this PR into `develop` is 2/19/2024 (six weeks after PR creation).** **DUE DATE for this PR is extended to 3/19/2024 because @XuLu-NOAA is on leave.** **Description** Xu Lu (xu.lu@noaa.gov) and Biju Thomas (biju.thomas@noaa.gov) fixed bugs regarding HAFS GSI debug build and run issues. This is in corresponding to issue #661 Fixes #661 1. In read_radar.f90, uninitialized toff is making all the ground-based radar observations be placed at -3h instead of 0h, which creates wrong increments for FGAT and 4DEnVar. 2. In read_radar.f90, uninitialized zsges will crash the debug mode. 3. In read_radar.f90, t4dvo should be used instead of t4dv in the read_radar_l2rw_novadqc subroutine. 4. In radinfo.90, maxscan should be increased to at least 252 to allow more scans, or it will crash the debug mode. 5. In read_fl_hdob.f90, dlnpsob is replaced with 1000. since the SFMR does not sample surface pressure, and the uninitialized dlnpsob creates issues later in setupspd.f90 in the debug mode. 6. In mod_fv3_lola.f90, (i,j+1) should be used instead of (i+1,j) in searching for V edges. 7. In stpcalc.f90, when tried to find the best stepsize from outpen around L838-864, the minimum outstp(i) is stored in stp(ii), but the istp_use is asigned with i instead of ii. Create inconsistency when assigning stp(istp_use) to stpinout at L872. Should use istp_use=ii instead. **Type of change** - [Yes] Bug fix (non-breaking change which fixes an issue) **How Has This Been Tested?** Regression test on Orion: ``` Test project /work/noaa/hwrf/save/xulu/mergeversions/GSI/build CMake Warning (dev) at CTestTestfile.cmake:9 (subdirs): Syntax Warning in cmake code at /work/noaa/hwrf/save/xulu/mergeversions/GSI/build/regression/CTestTestfile.cmake:7:10 1/7 Test #4: [=[netcdf_fv3_regional]=] ........ Passed 365.11 sec 2/7 Test #7: [=[global_enkf]=] ................ Passed 430.29 sec 3/7 Test #3: [=[rrfs_3denvar_glbens]=] ........ Passed 605.35 sec 4/7 Test #2: [=[rtma]=] ....................... Passed 969.78 sec 5/7 Test #6: [=[hafs_3denvar_hybens]=] ........***Failed 1455.47 sec 6/7 Test #1: [=[global_4denvar]=] ............. Passed 1682.40 sec 7/7 Test #5: [=[hafs_4denvar_glbens]=] ........***Failed 1758.90 sec ``` The failed hafs_3denvar and 4denvar are within expectation due to the fix for toff. As demonstrated in the single observation tests in the following figure, the uninitialized toff can result in increment degradations due to wrongly assigned observation times: ![image](https://github.com/NOAA-EMC/GSI/assets/26603014/0de870e1-f8c8-4b6d-8039-57f417b76367) --- src/gsi/mod_fv3_lola.f90 | 8 +++----- src/gsi/radinfo.f90 | 2 +- src/gsi/read_fl_hdob.f90 | 4 ++-- src/gsi/read_radar.f90 | 24 +++++++++++++----------- src/gsi/stpcalc.f90 | 4 ++-- 5 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/gsi/mod_fv3_lola.f90 b/src/gsi/mod_fv3_lola.f90 index e8df85068e..11bb3b6e37 100644 --- a/src/gsi/mod_fv3_lola.f90 +++ b/src/gsi/mod_fv3_lola.f90 @@ -951,7 +951,6 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l do i=1,nxen ! center lat/lon of the edge rlat=half*(grid_lat(i,j)+grid_lat(i+1,j)) -! rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 if(diff < sq180)then rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) @@ -979,12 +978,11 @@ subroutine definecoef_regular_grids(nxen,nyen,grid_lon,grid_lont,grid_lat,grid_l do j=1,nyen do i=1,nxen+1 rlat=half*(grid_lat(i,j)+grid_lat(i,j+1)) -! rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) - diff=(grid_lon(i,j)-grid_lon(i+1,j))**2 + diff=(grid_lon(i,j)-grid_lon(i,j+1))**2 if(diff < sq180)then - rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)) + rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)) else - rlon=half*(grid_lon(i,j)+grid_lon(i+1,j)-360._r_kind) + rlon=half*(grid_lon(i,j)+grid_lon(i,j+1)-360._r_kind) endif xr=cos(rlat*deg2rad)*cos(rlon*deg2rad) yr=cos(rlat*deg2rad)*sin(rlon*deg2rad) diff --git a/src/gsi/radinfo.f90 b/src/gsi/radinfo.f90 index ede58b9bca..4ad17626e6 100644 --- a/src/gsi/radinfo.f90 +++ b/src/gsi/radinfo.f90 @@ -897,7 +897,7 @@ subroutine radinfo_read ! Allocate arrays to receive angle dependent bias information. ! Open file to bias file (satang=satbias_angle). Read data. - maxscan=250 + maxscan=252 if (.not.adp_anglebc) maxscan = 90 ! default value for old files if (adp_anglebc) then diff --git a/src/gsi/read_fl_hdob.f90 b/src/gsi/read_fl_hdob.f90 index 1ef3d8617f..4041740d52 100644 --- a/src/gsi/read_fl_hdob.f90 +++ b/src/gsi/read_fl_hdob.f90 @@ -48,7 +48,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si use kinds, only: r_single,r_kind,r_double,i_kind use constants, only: zero,one_tenth,one,two,ten,deg2rad,t0c,half,& three,four,rad2deg,tiny_r_kind,huge_r_kind,r0_01,& - r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav + r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav,r_missing use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,& tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,& rlats,rlons,twodvar_regional,fv3_regional @@ -1133,7 +1133,7 @@ subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,si cdata_all( 1,iout)=woe ! wind error cdata_all( 2,iout)=dlon ! grid relative longitude cdata_all( 3,iout)=dlat ! grid relative latitude - cdata_all( 4,iout)=dlnpsob ! ln(surface pressure in cb) + cdata_all( 4,iout)=r_missing ! ln(surface pressure in cb) !Since dlnpsob is not provided by SFMR, force it to be r_missing. Not used in setupspd.f90 cdata_all( 5,iout)=spdob*sqrt(two)*half ! u obs cdata_all( 6,iout)=spdob*sqrt(two)*half ! v obs cdata_all( 7,iout)=rstation_id ! station id diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 index 5b1cffbf0c..a824bbbe4e 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -3282,7 +3282,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) use convinfo, only: nconvtype,ncmiter,ncgroup,ncnumgrp,icuse,ioctype,pmot_conv use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model use mpimod, only: npe - use obsmod, only: reduce_diag + use obsmod, only: reduce_diag,time_offset implicit none @@ -3323,7 +3323,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) integer(i_kind) iret,kx0 integer(i_kind) nreal,nchanl,ilat,ilon,ikx integer(i_kind) idomsfc - real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff + real(r_kind) usage,ff10,sfcr,skint,t4dvo real(r_kind) eradkm,dlat_earth,dlon_earth real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist @@ -3467,7 +3467,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) staheight=this_stahgt !station elevation tiltangle=corrected_tilt*deg2rad - t4dvo=toff+thistime + t4dvo=thistime+time_offset timemax=max(timemax,t4dvo) timemin=min(timemin,t4dvo) @@ -3586,7 +3586,8 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) end if if(usage >= 100._r_kind)rusage(ndata)=.true. - call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr) + call deter_zsfc_model(dlat,dlon,zsges) cdata(1) = error ! wind obs error (m/s) cdata(2) = dlon ! grid relative longitude @@ -3594,7 +3595,7 @@ subroutine read_radar_l2rw_novadqc(ndata,nodata,lunout,obstype,sis,nobs) cdata(4) = height ! obs absolute height (m) cdata(5) = rwnd ! wind obs (m/s) cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dv ! obs time (hour) + cdata(7) = t4dvo ! obs time (hour) cdata(8) = ikx ! type cdata(9) = tiltangle ! tilt angle (radians) cdata(10)= staheight ! station elevation (m) @@ -3699,6 +3700,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) use obsmod, only: doradaroneob,oneobradid,time_offset,reduce_diag use mpeu_util, only: gettablesize,gettable use convinfo, only: nconvtype,icuse,ioctype + use deter_sfc_mod, only: deter_sfc2,deter_zsfc_model use mpimod, only: npe use read_l2bufr_mod, only: radar_sites,radar_rmesh,radar_zmesh,elev_angle_max,del_time,range_max,radar_pmot use constants, only: eccentricity,somigliana,grav_ratio,grav,semi_major_axis,flattening,grav_equator @@ -3744,7 +3746,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) integer(i_kind) iret,kx0 integer(i_kind) nreal,nchanl,ilat,ilon,ikx integer(i_kind) idomsfc - real(r_kind) usage,ff10,sfcr,skint,t4dv,t4dvo,toff + real(r_kind) usage,ff10,sfcr,skint,t4dvo real(r_kind) eradkm,dlat_earth,dlon_earth real(r_kind) dlat,dlon,staheight,tiltangle,clon,slon,clat,slat real(r_kind) timeo,clonh,slonh,clath,slath,cdist,dist @@ -4071,7 +4073,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) slat=sin(dlat_earth) staheight=this_stahgt !station elevation tiltangle=corrected_tilt*deg2rad - t4dvo=toff+thistime + t4dvo=time_offset+thistime timemax=max(timemax,t4dvo) timemin=min(timemin,t4dvo) ! Exclude data if it does not fall within time window @@ -4166,7 +4168,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) if (l4dvar) then timedif = zero else - timedif=abs(t4dvo-toff) + timedif=abs(t4dvo-time_offset) endif crit1 = timedif/r6+half call map3grids_m(1,save_all,zflag,zl_thin,nlevz, & @@ -4233,8 +4235,8 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) end if ! Get information from surface file necessary for conventional data here -! call deter_zsfc_model(dlat,dlon,zsges) -! call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,skint,ff10,sfcr) + call deter_zsfc_model(dlat,dlon,zsges) + call deter_sfc2(dlat_earth,dlon_earth,t4dvo,idomsfc,skint,ff10,sfcr) nsuper2_kept=nsuper2_kept+1 cdata(1) = error ! wind obs error (m/s) @@ -4243,7 +4245,7 @@ subroutine read_radar_l2rw(ndata,nodata,lunout,obstype,sis,nobs,hgtl_full) cdata(4) = height ! obs absolute height (m) cdata(5) = rwnd ! wind obs (m/s) cdata(6) = azm*deg2rad ! azimuth angle (radians) - cdata(7) = t4dvo+time_offset ! obs time (hour) + cdata(7) = t4dvo ! obs time (hour) cdata(8) = ikx ! type cdata(9) = tiltangle ! tilt angle (radians) cdata(10)= staheight ! station elevation (m) diff --git a/src/gsi/stpcalc.f90 b/src/gsi/stpcalc.f90 index c66bb58291..34030763db 100644 --- a/src/gsi/stpcalc.f90 +++ b/src/gsi/stpcalc.f90 @@ -844,10 +844,10 @@ subroutine stpcalc(stpinout,sval,sbias,dirx,dval,dbias, & if(outpen(i) < outpensave)then stp(ii)=outstp(i) outpensave=outpen(i) - istp_use=i + istp_use=ii end if end do - if(istp_use /= istp_iter) then + if(istp_use /= nsteptot) then final_ii=ii exit stepsize end if From b2fc4fd92c49878af2381d985699c3f7987b8b4e Mon Sep 17 00:00:00 2001 From: Jeff Whitaker Date: Fri, 29 Mar 2024 07:57:50 -0600 Subject: [PATCH 20/35] add ability to taper analysis perts near top of model (#729) --- src/enkf/gridinfo_fv3reg.f90 | 34 +++++++++++++++++++++++++++------- src/enkf/gridinfo_gfs.f90 | 34 +++++++++++++++++++++++++++------- src/enkf/gridinfo_nmmb.f90 | 9 ++++++++- src/enkf/gridinfo_wrf.f90 | 9 +++++++-- src/enkf/inflation.f90 | 19 +++++++++++++------ src/enkf/params.f90 | 7 ++++++- 6 files changed, 88 insertions(+), 24 deletions(-) diff --git a/src/enkf/gridinfo_fv3reg.f90 b/src/enkf/gridinfo_fv3reg.f90 index 9a16f0ca03..337c9ba682 100644 --- a/src/enkf/gridinfo_fv3reg.f90 +++ b/src/enkf/gridinfo_fv3reg.f90 @@ -47,7 +47,8 @@ module gridinfo use mpimod, only: mpi_comm_world use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio, fgfileprefixes, & fv3fixpath, nx_res,ny_res, ntiles,l_fv3reg_filecombined,paranc, & - fv3_io_layout_nx,fv3_io_layout_ny + fv3_io_layout_nx,fv3_io_layout_ny,taperanalperts,taperanalperts_akbot, & + taperanalperts_aktop use kinds, only: r_kind, i_kind, r_double, r_single use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length @@ -65,6 +66,7 @@ module gridinfo public :: ak,bk,eta1_ll,eta2_ll real(r_single),public :: ptop real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +real(r_single),public, allocatable, dimension(:) :: taper_vert ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp @@ -133,7 +135,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) !when paranc=.false, fv3_io_layout_nx=fv3_io_layout_ny=1 ! read data on root task -if (nproc .eq. 0) then +if (nproc == 0) then ! read ak,bk from ensmean fv_core.res.nc ! read nx,ny and nz from fv_core.res.nc @@ -164,19 +166,35 @@ subroutine getgridinfo(fileprefix, reducedgrid) eta2_ll(i)=bk(i) enddo - - - ptop = eta1_ll(nlevsp1) call nc_check( nf90_close(file_id),& myname_,'close '//trim(filename) ) + + ! vertical taper function for ens perts + allocate(taper_vert(nlevs)) + if (taperanalperts) then + do k=1,nlevs + if (k < nlevs/2 .and. (ak(k) <= taperanalperts_akbot .and. ak(k) >= taperanalperts_aktop)) then + taper_vert(nlevs-k+1)= log(ak(k) - taperanalperts_aktop)/log(taperanalperts_akbot - taperanalperts_aktop) + else if (bk(k) == zero .and. ak(k) < taperanalperts_aktop) then + taper_vert(nlevs-k+1) = zero + endif + enddo + print *,'vertical taper for anal perts:' + do k=1,nlevs + print *,k,ak(nlevs-k+1),bk(nlevs-k+1),taper_vert(k) + enddo + else + taper_vert = one + endif + deallocate(ak,bk) endif ! root task allocate(nxlocgroup(fv3_io_layout_nx,fv3_io_layout_ny)) allocate(nylocgroup(fv3_io_layout_nx,fv3_io_layout_ny)) -if(nproc.eq.0) then +if(nproc == 0) then ii=0 do j=1,fv3_io_layout_ny do i=1,fv3_io_layout_nx @@ -463,7 +481,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) allocate(gridloc(3,npts)) if (nproc .ne. 0) then ! allocate arrays on other (non-root) tasks - allocate(latsgrd(npts),lonsgrd(npts)) + allocate(latsgrd(npts),lonsgrd(npts),taper_vert(nlevs)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(eta1_ll(nlevsp1),eta2_ll(nlevsp1)) endif @@ -473,6 +491,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(eta1_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(eta2_ll,nlevsp1,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) @@ -489,6 +508,7 @@ end subroutine getgridinfo subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/gridinfo_gfs.f90 b/src/enkf/gridinfo_gfs.f90 index de71153c69..efbd7a2959 100644 --- a/src/enkf/gridinfo_gfs.f90 +++ b/src/enkf/gridinfo_gfs.f90 @@ -45,7 +45,8 @@ module gridinfo use mpisetup, only: nproc, mpi_integer, mpi_real4 use mpimod, only: mpi_comm_world -use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes +use params, only: datapath,nlevs,nlons,nlats,use_gfs_nemsio,use_gfs_ncio,fgfileprefixes,& + taperanalperts,taperanalperts_aktop,taperanalperts_akbot use kinds, only: r_kind, i_kind, r_double, r_single use constants, only: one,zero,pi,cp,rd,grav,rearth,max_varname_length use specmod, only: sptezv_s, sptez_s, init_spec_vars, isinitialized, asin_gaulats, & @@ -57,7 +58,7 @@ module gridinfo public :: getgridinfo, gridinfo_cleanup integer(i_kind),public :: nlevs_pres, idvc real(r_single),public :: ptop -real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd, taper_vert ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp @@ -105,7 +106,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) kapr = cp/rd kap1 = kap + one nlevs_pres=nlevs+1 -if (nproc .eq. 0) then +if (nproc == 0) then filename = trim(adjustl(datapath))//trim(adjustl(fileprefix))//"ensmean" if (use_gfs_nemsio) then call nemsio_init(iret=iret) @@ -168,11 +169,13 @@ subroutine getgridinfo(fileprefix, reducedgrid) ! initialize spectral module on all tasks. if (.not. isinitialized) call init_spec_vars(nlons,nlats,ntrunc,4) -if (nproc .eq. 0) then +if (nproc == 0) then ! get pressure, lat/lon information from ensemble mean file. allocate(presslmn(nlons*nlats,nlevs)) allocate(pressimn(nlons*nlats,nlevs+1)) allocate(spressmn(nlons*nlats)) + allocate(taper_vert(nlevs)) + taper_vert=one if (use_gfs_nemsio) then call nemsio_readrecv(gfile,'pres','sfc',1,nems_wrk,iret=iret) if (iret/=0) then @@ -221,7 +224,6 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call nemsio_close(gfile, iret=iret) ptop = ak(nlevs+1) - deallocate(ak,bk) else if (use_gfs_ncio) then call read_vardata(dset, 'pressfc', values_2d,errcode=iret) if (iret /= 0) then @@ -238,7 +240,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) pressimn(:,k) = 0.01_r_kind*ak(nlevs-k+2)+bk(nlevs-k+2)*spressmn(:) enddo ptop = 0.01_r_kind*ak(1) - deallocate(ak,bk,values_2d) + deallocate(values_2d) else ! get pressure from ensemble mean, ! distribute to all processors. @@ -278,7 +280,6 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call sigio_axdata(sigdata,iret) ptop = ak(nlevs+1) - deallocate(ak,bk) endif if (reducedgrid) then call reducedgrid_init(nlons,nlats,asin_gaulats) @@ -334,11 +335,28 @@ subroutine getgridinfo(fileprefix, reducedgrid) logp(:,nlevs_pres) = -log(spressmn(:)) endif deallocate(spressmn,presslmn,pressimn) + ! vertical taper function for ens perts + if (taperanalperts) then + do k=1,nlevs + if (k < nlevs/2 .and. (ak(k) <= taperanalperts_akbot .and. ak(k) >= taperanalperts_aktop)) then + taper_vert(nlevs-k+1)= log(ak(k) - taperanalperts_aktop)/log(taperanalperts_akbot - taperanalperts_aktop) + else if (bk(k) == zero .and. ak(k) < taperanalperts_aktop) then + taper_vert(nlevs-k+1) = zero + endif + enddo + print *,'vertical taper for anal perts:' + do k=1,nlevs + print *,k,ak(nlevs-k+1),bk(nlevs-k+1),taper_vert(k) + enddo + endif + if (allocated(ak)) deallocate(ak) + if (allocated(bk)) deallocate(bk) end if call mpi_bcast(npts,1,MPI_INTEGER,0,MPI_COMM_WORLD,ierr) if (nproc .ne. 0) then ! allocate arrays on other (non-root) tasks allocate(latsgrd(npts),lonsgrd(npts)) + allocate(taper_vert(nlevs)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(gridloc(3,npts)) ! initialize reducedgrid_mod on other tasks. @@ -352,6 +370,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) !==> precompute cartesian coords of analysis grid points. do nn=1,npts @@ -365,6 +384,7 @@ end subroutine getgridinfo subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/gridinfo_nmmb.f90 b/src/enkf/gridinfo_nmmb.f90 index df6c22ee1e..33b487354e 100644 --- a/src/enkf/gridinfo_nmmb.f90 +++ b/src/enkf/gridinfo_nmmb.f90 @@ -1,6 +1,7 @@ module gridinfo -use mpisetup +use mpisetup, only: nproc, mpi_integer, mpi_real4 +use mpimod, only: mpi_comm_world use params, only: datapath,nlevs,datestring,& nmmb,regional,nlons,nlats,nbackgrounds,fgfileprefixes use kinds, only: r_kind, i_kind, r_double, r_single @@ -16,6 +17,7 @@ module gridinfo integer(i_kind),public :: nlevs_pres real(r_single),public :: ptop real(r_single),public, allocatable, dimension(:) :: lonsgrd, latsgrd +real(r_single),public, allocatable, dimension(:) :: taper_vert ! arrays passed to kdtree2 routines must be single real(r_single),public, allocatable, dimension(:,:) :: gridloc real(r_single),public, allocatable, dimension(:,:) :: logp @@ -124,6 +126,8 @@ subroutine getgridinfo(fileprefix, reducedgrid) allocate(latsgrd(npts),lonsgrd(npts)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(gridloc(3,npts)) + allocate(taper_vert(nlevs)) + taper_vert=one lonsgrd = lons; latsgrd = lats print *,'min/max lonsgrd',minval(lonsgrd),maxval(lonsgrd) print *,'min/max latsgrd',minval(latsgrd),maxval(latsgrd) @@ -165,6 +169,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) if (nproc .ne. 0) then ! allocate arrays on other (non-root) tasks allocate(latsgrd(npts),lonsgrd(npts)) + allocate(taper_vert(nlevs)) allocate(logp(npts,nlevs_pres)) ! log(ens mean first guess press) on mid-layers allocate(gridloc(3,npts)) endif @@ -174,6 +179,7 @@ subroutine getgridinfo(fileprefix, reducedgrid) enddo call mpi_bcast(lonsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(latsgrd,npts,mpi_real4,0,MPI_COMM_WORLD,ierr) +call mpi_bcast(taper_vert,nlevs,mpi_real4,0,MPI_COMM_WORLD,ierr) call mpi_bcast(ptop,1,mpi_real4,0,MPI_COMM_WORLD,ierr) !==> precompute cartesian coords of analysis grid points. @@ -188,6 +194,7 @@ end subroutine getgridinfo subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) +if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/gridinfo_wrf.f90 b/src/enkf/gridinfo_wrf.f90 index e67b827b41..4ad80aaa60 100644 --- a/src/enkf/gridinfo_wrf.f90 +++ b/src/enkf/gridinfo_wrf.f90 @@ -32,12 +32,13 @@ module gridinfo ! Define associated modules - use constants, only: rearth_equator, omega, pi, deg2rad, zero, rad2deg, & + use constants, only: rearth_equator, omega, pi, deg2rad, zero, one, rad2deg, & rearth,max_varname_length use kinds, only: i_kind, r_kind, r_single, i_long, r_double use params, only: datapath, nlevs, nlons, nlats, & arw, nmm - use mpisetup + use mpisetup, only: nproc, mpi_integer, mpi_real4,mpi_status + use mpimod, only: mpi_comm_world use netcdf_io implicit none @@ -63,6 +64,7 @@ module gridinfo real(r_single), dimension(:,:), allocatable, public :: gridloc real(r_single), dimension(:), allocatable, public :: lonsgrd real(r_single), dimension(:), allocatable, public :: latsgrd + real(r_single), dimension(:), allocatable, public :: taper_vert real(r_single), public :: ptop integer(i_long), public :: npts integer(i_kind), public :: nlevs_pres @@ -211,7 +213,9 @@ subroutine getgridinfo_arw(fileprefix) ! Allocate memory for global arrays if(.not. allocated(lonsgrd)) allocate(lonsgrd(npts)) if(.not. allocated(latsgrd)) allocate(latsgrd(npts)) + if(.not. allocated(taper_vert)) allocate(taper_vert(nlevs)) if(.not. allocated(logp)) allocate(logp(npts,nlevs_pres)) + taper_vert = one !====================================================================== ! Begin: Ingest all grid variables required for EnKF routines and @@ -848,6 +852,7 @@ end subroutine dot2cross subroutine gridinfo_cleanup() if (allocated(lonsgrd)) deallocate(lonsgrd) if (allocated(latsgrd)) deallocate(latsgrd) + if (allocated(taper_vert)) deallocate(taper_vert) if (allocated(logp)) deallocate(logp) if (allocated(gridloc)) deallocate(gridloc) end subroutine gridinfo_cleanup diff --git a/src/enkf/inflation.f90 b/src/enkf/inflation.f90 index 51d1dd1106..c80cc99c10 100644 --- a/src/enkf/inflation.f90 +++ b/src/enkf/inflation.f90 @@ -71,14 +71,14 @@ module inflation analpertwtnh_rtpp,analpertwtsh_rtpp,analpertwttr_rtpp,& latbound, delat, datapath, covinflatemax, save_inflation, & covinflatemin, nlons, nlats, smoothparm, nbackgrounds,& - covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff + covinflatenh,covinflatesh,covinflatetr,lnsigcovinfcutoff,taperanalperts use kinds, only: r_single, i_kind use mpeu_util, only: getindex use constants, only: one, zero, rad2deg, deg2rad use covlocal, only: latval, taper -use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels +use controlvec, only: ncdim, cvars3d, cvars2d, nc3d, nc2d, clevels, index_pres ! note: vars2d_landonly currently only defined for gridio_gfs, but smoothing only coded for gfs. -use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly +use gridinfo, only: latsgrd, logp, npts, nlevs_pres, vars2d_landonly, taper_vert use loadbal, only: indxproc, numptsperproc, npts_max, anal_chunk, anal_chunk_prior use smooth_mod, only: smooth @@ -102,7 +102,7 @@ subroutine inflate_ens() real(r_single),dimension(ndiag) :: sumcoslat,suma,suma2,sumi,sumf,sumitot,sumatot, & sumcoslattot,suma2tot,sumftot real(r_single) fnanalsml,coslat -integer(i_kind) i,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind +integer(i_kind) i,k,nlev,nn,iunit,ierr,nb,nnlvl,ps_ind, this_ind, ind integer(i_kind), dimension(8) :: soil_index character(len=500) filename real(r_single), allocatable, dimension(:,:) :: tmp_chunk2,covinfglobal,store_presmooth @@ -113,7 +113,7 @@ subroutine inflate_ens() if (analpertwtnh_rtpp > 1.e-5_r_single .and. & analpertwtnh_rtpp > 1.e-5_r_single .and. & analpertwttr_rtpp > 1.e-5_r_single) then -if (nproc .eq. 0) print *,'performing RTPP inflation...' +if (nproc == 0) print *,'performing RTPP inflation...' nbloop: do nb=1,nbackgrounds ! loop over time levels in background ! First perform RTPP ensemble inflation, ! as first described in: @@ -139,7 +139,7 @@ subroutine inflate_ens() abs(analpertwttr) < 1.e-5_r_single .and. & abs(analpertwtsh) < 1.e-5_r_single) return -if (nproc .eq. 0) print *,'performing RTPS inflation...' +if (nproc == 0) print *,'performing RTPS inflation...' ! now perform RTPS inflation nbloop2: do nb=1,nbackgrounds ! loop over time levels in background @@ -302,11 +302,18 @@ subroutine inflate_ens() ! apply inflation. do nn=1,ncdim + nlev = index_pres(nn) ! vertical index for i'th control variable + if (nlev == nlevs+1) nlev=-1 ! 2d field do i=1,numptsperproc(nproc+1) ! inflate posterior perturbations. anal_chunk(:,i,nn,nb) = tmp_chunk2(i,nn)*anal_chunk(:,i,nn,nb) + ! optionally 'deflate' perturbations to reduce spread near top of model + if (taperanalperts .and. nlev > 0) then + anal_chunk(:,i,nn,nb) = taper_vert(nlev)*anal_chunk(:,i,nn,nb) + endif + ! area mean surface pressure posterior spread, inflation. ! (this diagnostic only makes sense for grids that are regular in longitude) if (ps_ind > 0 .and. nn == clevels(nc3d) + ps_ind) then diff --git a/src/enkf/params.f90 b/src/enkf/params.f90 index 36b0c9c207..f2a52d9a1a 100644 --- a/src/enkf/params.f90 +++ b/src/enkf/params.f90 @@ -254,6 +254,11 @@ module params ! write ensemble mean analysis (or analysis increment) logical,public :: write_ensmean = .false. +! taper analysis ens perturbations at top of model (gfs only) +logical, public :: taperanalperts = .false. +real(r_kind), public :: taperanalperts_akbot = 500.0_r_kind +real(r_kind), public :: taperanalperts_aktop = -1.0_r_kind + namelist /nam_enkf/datestring,datapath,iassim_order,nvars,& covinflatemax,covinflatemin,deterministic,sortinc,& mincorrlength_fact,corrlengthnh,corrlengthtr,corrlengthsh,& @@ -286,7 +291,7 @@ module params fv3_native, paranc, nccompress, write_fv3_incr,incvars_to_zero,write_ensmean, & corrlengthrdrnh,corrlengthrdrsh,corrlengthrdrtr,& lnsigcutoffrdrnh,lnsigcutoffrdrsh,lnsigcutoffrdrtr,& - l_use_enkf_directZDA + l_use_enkf_directZDA,taperanalperts,taperanalperts_akbot,taperanalperts_aktop namelist /nam_wrf/arw,nmm,nmm_restart namelist /nam_fv3/fv3fixpath,nx_res,ny_res,ntiles,l_pres_add_saved,l_fv3reg_filecombined, & fv3_io_layout_nx,fv3_io_layout_ny From db477e361f75f412c69ca6fdf9acfd411628f403 Mon Sep 17 00:00:00 2001 From: JingCheng-NOAA <135154465+JingCheng-NOAA@users.noreply.github.com> Date: Mon, 1 Apr 2024 14:15:10 -0400 Subject: [PATCH 21/35] Update the QC for the enhanced high-resolution GOES-R mesoscale floater AMVs (#724) **Description** This is an update of the QC process for the enhanced high-resolution GOES-R mesoscale floater AMVs to resolve the issue #713. As mentioned in the issue, enhanced AMV data are derived from IR band, which turns out to be not reliable in the mid-layer of atmosphere. Adding additional QC process to remove data in those layers are necessary and proved to enhance the Hurricane intensity forecast. **Type of change** Please delete options that are not relevant. - [ ] Bug fix (non-breaking change which fixes an issue) - [x] New feature (non-breaking change which adds functionality) - [ ] Breaking change (fix or feature that would cause existing functionality to not work as expected) - [ ] This change requires a documentation update **How Has This Been Tested?** This change has been tested with GSI regression test on Hera. **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes - [x] Any dependent changes have been merged and published --- src/gsi/setupw.f90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/gsi/setupw.f90 b/src/gsi/setupw.f90 index e350c7deba..e7dd08c5f5 100644 --- a/src/gsi/setupw.f90 +++ b/src/gsi/setupw.f90 @@ -945,7 +945,11 @@ subroutine setupw(obsLL,odiagLL,lunin,mype,bwork,awork,nele,nobs,is,conv_diagsav else if( presw >950.0_r_kind) error =zero ! screen data beloww 950mb endif - if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT + if(itype == 241 ) then + if( presw >399.0_r_kind .and. presw <601.0_r_kind) then !CIMISS(enhanced AMV) winds + error=zero ! no data between400-600mb + endif + else if(itype ==242 .or. itype ==243 ) then ! visible winds from JMA and EUMETSAT if(presw <700.0_r_kind) error=zero ! no visible winds above 700mb else if(itype ==245 ) then if( presw >399.0_r_kind .and. presw <801.0_r_kind) then !GOES IR winds From 29d9d8fdea7e5139bca6bdd135711a33e7bf25a6 Mon Sep 17 00:00:00 2001 From: Gang Zhao <53267411+GangZhao-NOAA@users.noreply.github.com> Date: Fri, 5 Apr 2024 09:39:54 -0400 Subject: [PATCH 22/35] Adding I/O for direct analysis of near-surface wind gust for RRFS-based 3DRTMA (#730) **Description** To improve the analysis of the near-surface wind gust in 3DRTMA, the observations of near-surface wind gust would be analyzed directly in GSI (3DVar and Hybrid 3DEnVar), instead of being a derived product from the near-surface wind analysis. Since the core subroutines for direct variational assimilation of wind gust (e.g., setupgust.f90, intgust.f90, stpgust.f90, etc.) had already been implemented in GSI for 2DRTMA, so in the work the development in GSI mainly focus on adding I/O of 2-D wind gust firstguess and analysis fields for RRFS-based 3DRTMA, and some minor modifications in observation and background error for wind gust, options to control the analysis of wind gust, etc. This PR is to address the issue #726 : Adding I/O for direct analysis of near-surface wind gust for RRFS-based 3DRTMA Fixes #726 **Type of change** Please delete options that are not relevant. - [x] New feature (non-breaking change which adds functionality) **How Has This Been Tested?** **Checklist** - [x] My code follows the style guidelines of this project - [x] I have performed a self-review of my own code - [x] I have commented my code, particularly in hard-to-understand areas - [x] New and existing tests pass with my changes tested with a real case - 2024-02-20_12:00Z, 1. dry-run (using my updated GSI code with wind gust analysis, but actually no wind gust obs is analyzed, so-called dryrun) is compared to control-run (original GSI code running without wind gust obs): the results are identical. This indicates that if without analyzing wind-gust obs, then the updated code generates the analysis identical to the analysis of original/control code. Or say, the added code does not have influence on the other part of code. 2. real case run with updated GSI code to analyze the obs of wind gust: The following figure shows the used observations of near-surface wind gust: ![var_obs_2024022012_gust_used_maprll_datll_reg_ncf](https://github.com/NOAA-EMC/GSI/assets/53267411/ecbe479a-03c6-490f-a179-9e0027291468) the following figure shows the analysis increments: ![GUST_hyb_hwllp90_corptuned_inc_incrintrp_maprll_datrll_reg_grb2](https://github.com/NOAA-EMC/GSI/assets/53267411/a01fca0d-dc1f-438b-b8eb-e624de35a631) - [x] Any dependent changes have been merged and published - [x] Regression tests on WCOSS2 (Cactus) and Hera (Rocky-8) : my updated GSI commit [#f91f247d](https://github.com/GangZhao-NOAA/GSI/commit/f91f247dde65dea0b659c0b78d747433d9ca9559)) vs control/original GSI code (commit [#6d9ebbb7](https://github.com/NOAA-EMC/GSI/commit/6d9ebbb7896b92a93959ce63c7a1ad9e9a0aab4f)) Here is the reports of the regression tests on WCOSS2 (Cactus): ~~~ [gang.zhao@clogin02:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -j 7 Test project /lfs/h2/emc/da/save/gang.zhao/WorkDir/ProdGSI_Dev/gsi_dev/build Start 1: global_4denvar Start 2: rtma Start 3: rrfs_3denvar_glbens Start 4: netcdf_fv3_regional Start 5: hafs_4denvar_glbens Start 6: hafs_3denvar_hybens Start 7: global_enkf 1/7 Test #4: netcdf_fv3_regional .............. Passed 483.15 sec 2/7 Test #3: rrfs_3denvar_glbens .............. Passed 486.74 sec 3/7 Test #7: global_enkf ...................... Passed 850.98 sec 4/7 Test #2: rtma ............................. Passed 970.28 sec 5/7 Test #6: hafs_3denvar_hybens .............. Passed 1152.82 sec 6/7 Test #5: hafs_4denvar_glbens .............. Passed 1213.93 sec 7/7 Test #1: global_4denvar ................... Passed 1683.16 sec 100% tests passed, 0 tests failed out of 7 Total Test time (real) = 1683.19 sec ~~~ Here is the reports of the regression tests on Hera (Rocky8): ~~~ (base) [Gang.Zhao@hfe11:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -j 7 Test project /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build Start 1: global_4denvar Start 2: rtma Start 3: rrfs_3denvar_glbens Start 4: netcdf_fv3_regional Start 5: hafs_4denvar_glbens Start 6: hafs_3denvar_hybens Start 7: global_enkf 1/7 Test #4: netcdf_fv3_regional .............. Passed 491.53 sec 2/7 Test #3: rrfs_3denvar_glbens ..............***Failed 495.27 sec 3/7 Test #2: rtma ............................. Passed 982.45 sec 4/7 Test #6: hafs_3denvar_hybens .............. Passed 1168.99 sec 5/7 Test #7: global_enkf ...................... Passed 1239.77 sec 6/7 Test #5: hafs_4denvar_glbens ..............***Failed 1347.87 sec 7/7 Test #1: global_4denvar ................... Passed 1974.45 sec 71% tests passed, 2 tests failed out of 7 Total Test time (real) = 1974.91 sec The following tests FAILED: 3 - rrfs_3denvar_glbens (Failed) 5 - hafs_4denvar_glbens (Failed) Errors while running CTest Output from these tests are in: /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build/Testing/Temporary/LastTest.log Use "--rerun-failed --output-on-failure" to re-run the failed cases verbosely. (base) [Gang.Zhao@hfe11:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -R rrfs_3denvar_glbens Test project /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build Start 3: rrfs_3denvar_glbens 1/1 Test #3: rrfs_3denvar_glbens .............. Passed 430.52 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 430.55 sec (base) [Gang.Zhao@hfe11:build] (feature/windgust_in_3dvar_for_3drtma)$ ctest -R hafs_4denvar_glbens Test project /scratch1/NCEPDEV/da/Gang.Zhao/ProdGSI_dev/gsi_dev/build Start 5: hafs_4denvar_glbens 1/1 Test #5: hafs_4denvar_glbens .............. Passed 1225.37 sec 100% tests passed, 0 tests failed out of 1 Total Test time (real) = 1225.39 sec ~~~ **Note**: _When I was running the regression tests, GSI code was just updated to the latest commit [#b53740a7](https://github.com/GangZhao-NOAA/GSI/commit/f91f247dde65dea0b659c0b78d747433d9ca9559). Considering the frequent update in EMC GSI code recently and saving the time, after this PR has been reviewed and approved by peer-reviewers, I will update the code to latest EMC GSI commit, then re-run the regression tests for final approval. --- src/gsi/gsi_rfv3io_mod.f90 | 65 +++++++++++++++++++++++----- src/gsi/gsimod.F90 | 7 ++- src/gsi/m_berror_stats_reg.f90 | 29 ++++++++++++- src/gsi/rapidrefresh_cldsurf_mod.f90 | 50 +++++++++++++++++++++ src/gsi/read_prepbufr.f90 | 5 ++- 5 files changed, 140 insertions(+), 16 deletions(-) diff --git a/src/gsi/gsi_rfv3io_mod.f90 b/src/gsi/gsi_rfv3io_mod.f90 index 652bad9a33..8e1c3ab98f 100644 --- a/src/gsi/gsi_rfv3io_mod.f90 +++ b/src/gsi/gsi_rfv3io_mod.f90 @@ -61,7 +61,7 @@ module gsi_rfv3io_mod use rapidrefresh_cldsurf_mod, only: i_use_2mq4b,i_use_2mt4b use chemmod, only: naero_cmaq_fv3,aeronames_cmaq_fv3,imodes_cmaq_fv3,laeroana_fv3cmaq use chemmod, only: naero_smoke_fv3,aeronames_smoke_fv3,laeroana_fv3smoke - use rapidrefresh_cldsurf_mod, only: i_howv_3dda + use rapidrefresh_cldsurf_mod, only: i_howv_3dda, i_gust_3dda implicit none public type_fv3regfilenameg @@ -147,7 +147,7 @@ module gsi_rfv3io_mod public :: mype_u,mype_v,mype_t,mype_q,mype_p,mype_oz,mype_ql public :: mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w public :: k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc - public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv + public :: k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv,k_gust public :: ijns,ijns2d,displss,displss2d,ijnz,displsz_g public :: fv3lam_io_dynmetvars3d_nouv,fv3lam_io_tracermetvars3d_nouv public :: fv3lam_io_tracerchemvars3d_nouv,fv3lam_io_tracersmokevars3d_nouv @@ -158,7 +158,7 @@ module gsi_rfv3io_mod integer(i_kind) mype_qi,mype_qr,mype_qs,mype_qg,mype_qnr,mype_w integer(i_kind) k_slmsk,k_tsea,k_vfrac,k_vtype,k_stype,k_zorl,k_smc,k_stc - integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv + integer(i_kind) k_snwdph,k_f10m,mype_2d,n2d,k_orog,k_psfc,k_t2m,k_q2m,k_howv,k_gust parameter( & k_f10m =1, & !fact10 k_stype=2, & !soil_type @@ -174,7 +174,8 @@ module gsi_rfv3io_mod k_q2m =12, & ! 2 m Q k_orog =13, & !terrain k_howv =14, & ! significant wave height (aka howv in GSI) - n2d=14 ) + k_gust =15, & ! wind gust (aka gust in GSI) + n2d=15 ) logical :: grid_reverse_flag character(len=max_varname_length),allocatable,dimension(:) :: fv3lam_io_dynmetvars3d_nouv ! copy of cvars3d excluding uv 3-d fields @@ -996,6 +997,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) real(r_kind),dimension(:,:),pointer::ges_t2m=>NULL() real(r_kind),dimension(:,:),pointer::ges_q2m=>NULL() real(r_kind),dimension(:,:),pointer::ges_howv=>NULL() + real(r_kind),dimension(:,:),pointer::ges_gust=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_ql=>NULL() real(r_kind),dimension(:,:,:),pointer::ges_qi=>NULL() @@ -1274,6 +1276,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) else if(trim(vartem)=='t2m') then else if(trim(vartem)=='q2m') then else if(trim(vartem)=='howv') then + else if(trim(vartem)=='gust') then else write(6,*)'the metvarname2 ',trim(vartem),' has not been considered yet, stop' call stop2(333) @@ -1294,7 +1297,7 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) vartem=trim(name_metvars2d(i)) if(.not.( (trim(vartem)=='ps'.and.fv3sar_bg_opt==0).or.(trim(vartem)=="z") & .or.(trim(vartem)=="t2m").or.(trim(vartem)=="q2m") & - .or.(trim(vartem)=="howv"))) then ! z is treated separately + .or.(trim(vartem)=="howv").or.(trim(vartem)=="gust"))) then ! z is treated separately if (ifindstrloc(vardynvars,trim(vartem)) > 0) then jdynvar=jdynvar+1 fv3lam_io_dynmetvars2d_nouv(jdynvar)=trim(vartem) @@ -1557,6 +1560,12 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) if (ier/=0) call die(trim(myname),'cannot get pointers for howv, ier=',ier) endif +!--- wind gust (gust) + if ( i_gust_3dda == 1 ) then + call GSI_BundleGetPointer(GSI_MetGuess_Bundle(it),'gust',ges_gust,istatus ); ier=ier+istatus + if (ier/=0) call die(trim(myname),'cannot get pointers for gust, ier=',ier) + endif + if(mype == 0 ) then call check(nf90_open(fv3filenamegin(it)%dynvars,nf90_nowrite,loc_id)) call check(nf90_inquire(loc_id,formatNum=ncfmt)) @@ -1739,7 +1748,8 @@ subroutine read_fv3_netcdf_guess(fv3filenamegin) endif - call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m,ges_howv) + call gsi_fv3ncdf2d_read(fv3filenamegin(it),it,ges_z,ges_t2m,ges_q2m, & + ges_howv,ges_gust) if(i_use_2mq4b > 0 .and. i_use_2mt4b > 0 ) then ! Convert 2m guess mixing ratio to specific humidity @@ -1975,7 +1985,8 @@ end subroutine gsi_bundlegetpointer_fv3lam_tracerchem_nouv end subroutine read_fv3_netcdf_guess -subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) +subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m, & + ges_howv,ges_gust) !$$$ subprogram documentation block ! . . . . ! subprogram: gsi_fv3ncdf2d_read @@ -2022,6 +2033,7 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) real(r_kind), intent(in),dimension(:,:),pointer::ges_t2m real(r_kind), intent(in),dimension(:,:),pointer::ges_q2m real(r_kind), intent(in),dimension(:,:),pointer::ges_howv + real(r_kind), intent(in),dimension(:,:),pointer::ges_gust type (type_fv3regfilenameg),intent(in) :: fv3filenamegin character(len=max_varname_length) :: name @@ -2036,8 +2048,8 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) integer(i_kind) kk,n,ns,j,ii,jj,mm1 character(len=:),allocatable :: sfcdata !='fv3_sfcdata' character(len=:),allocatable :: dynvars !='fv3_dynvars' -! for checking the existence of howv in firstguess file - integer(i_kind) id_howv +! for checking the existence of howv/gust in firstguess file + integer(i_kind) id_howv, id_gust integer(i_kind) iret_bcast ! for io_layout > 1 @@ -2057,8 +2069,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) allocate(work(itotsub*n2d)) allocate( sfcn2d(lat2,lon2,n2d)) -!-- initialisation of the array for howv +!-- initialisation of the array for howv/gust sfcn2d(:,:,k_howv) = zero + sfcn2d(:,:,k_gust) = zero !-- initialisation of the array for sfc_var_exist sfc_var_exist = .false. @@ -2107,6 +2120,21 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) trim(sfcdata), ', iret, varid = ',iret, id_howv,' (on pe: ', mype,').' end if end if +!--- check the existence of wind gust (gust) in 2D FV3-LAM firstguess file +! (similar as done above for howv) + if ( i_gust_3dda == 1 ) then + iret = nf90_inq_varid(gfile_loc,'gust',id_gust) + if ( iret /= nf90_noerr ) then + iret = nf90_inq_varid(gfile_loc,'GUST',id_gust) ! double check with name in uppercase + end if + if ( iret /= nf90_noerr ) then + i_gust_3dda = 0 ! gust does not exist in firstguess, then stop GSI run. + call die('gsi_fv3ncdf2d_read','Warning: CANNOT find gust in firstguess, aborting..., iret = ', iret) + else + write(6,'(1x,A,1x,A,1x,A,1x,I4,1x,I4,1x,A,1x,I4.4,A)') 'gsi_fv3ncdf2d_read:: Found gust in firstguess ', & + trim(sfcdata), ', iret, varid = ',iret, id_gust,' (on pe: ', mype,').' + end if + end if !!!!!!!!!!!! read in 2d variables !!!!!!!!!!!!!!!!!!!!!!!!!! do i=ndimensions+1,nvariables @@ -2150,6 +2178,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) else if( trim(name)=='HOWV'.or.trim(name)=='howv' ) then k=k_howv sfc_var_exist(k) = .true. + else if( trim(name)=='GUST'.or.trim(name)=='gust' ) then + k=k_gust + sfc_var_exist(k) = .true. else cycle endif @@ -2283,8 +2314,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) if(allocated(sfc_fulldomain)) deallocate (sfc_fulldomain) endif ! mype -!-- broadcast the updated i_howv_3dda to all tasks (!!!!) +!-- broadcast the updated i_howv_3dda, i_gust_3dda to all tasks (!!!!) call mpi_bcast(i_howv_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) + call mpi_bcast(i_gust_3dda, 1, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) !-- broadcast the updated sfc_var_exist to all tasks (!!!!) call mpi_bcast(sfc_var_exist, n2d, mpi_itype, mype_2d, mpi_comm_world, iret_bcast) @@ -2313,6 +2345,9 @@ subroutine gsi_fv3ncdf2d_read(fv3filenamegin,it,ges_z,ges_t2m,ges_q2m,ges_howv) if ( i_howv_3dda == 1 ) then if ( sfc_var_exist(k_howv) ) ges_howv(:,:)=sfcn2d(:,:,k_howv) endif + if ( i_gust_3dda == 1 ) then + if ( sfc_var_exist(k_gust) ) ges_gust(:,:)=sfcn2d(:,:,k_gust) + endif deallocate (sfcn2d,a) return end subroutine gsi_fv3ncdf2d_read @@ -3628,6 +3663,7 @@ subroutine wrfv3_netcdf(fv3filenamegin) real(r_kind),pointer,dimension(:,: ):: ges_t2m =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_q2m =>NULL() real(r_kind),pointer,dimension(:,: ):: ges_howv =>NULL() + real(r_kind),pointer,dimension(:,: ):: ges_gust =>NULL() integer(i_kind) i,k @@ -3750,6 +3786,9 @@ subroutine wrfv3_netcdf(fv3filenamegin) if ( i_howv_3dda == 1 ) then call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'howv',ges_howv,istatus); ier=ier+istatus endif + if ( i_gust_3dda == 1 ) then + call GSI_BundleGetPointer (GSI_MetGuess_Bundle(it),'gust',ges_gust,istatus); ier=ier+istatus + endif if (ier/=0) call die('wrfv3_netcdf','cannot get pointers for fv3 met-fields, ier =',ier) if (laeroana_fv3cmaq) then @@ -3964,6 +4003,10 @@ subroutine wrfv3_netcdf(fv3filenamegin) if ( i_howv_3dda == 1 ) then call gsi_fv3ncdf_write_sfc(fv3filenamegin,'howv',ges_howv,add_saved) endif +!-- output analysis of gust + if ( i_gust_3dda == 1 ) then + call gsi_fv3ncdf_write_sfc(fv3filenamegin,'gust',ges_gust,add_saved) + endif if(allocated(g_prsi)) deallocate(g_prsi) diff --git a/src/gsi/gsimod.F90 b/src/gsi/gsimod.F90 index 8a1ce896bb..d7f5667252 100644 --- a/src/gsi/gsimod.F90 +++ b/src/gsi/gsimod.F90 @@ -184,7 +184,7 @@ module gsimod cld_bld_coverage,cld_clr_coverage,& i_cloud_q_innovation,i_ens_mean,DTsTmax,& i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, & - corp_howv, hwllp_howv + corp_howv, hwllp_howv, corp_gust, hwllp_gust, oerr_gust use gsi_metguess_mod, only: gsi_metguess_init,gsi_metguess_final use gsi_chemguess_mod, only: gsi_chemguess_init,gsi_chemguess_final use tcv_mod, only: init_tcps_errvals,tcp_refps,tcp_width,tcp_ermin,tcp_ermax @@ -1604,6 +1604,9 @@ module gsimod ! = 0.42 meters (default) ! hwllp_howv - real, background error de-correlation length scale of howv ! = 170,000.0 meters (default 170 km) +! corp_gust - real, static background error of gust (stddev error) +! hwllp_gust - real, background error de-correlation length scale of gust +! oerr_gust - real, observation error of gust ! namelist/rapidrefresh_cldsurf/dfi_radar_latent_heat_time_period, & metar_impact_radius,metar_impact_radius_lowcloud, & @@ -1625,7 +1628,7 @@ module gsimod cld_bld_coverage,cld_clr_coverage,& i_cloud_q_innovation,i_ens_mean,DTsTmax, & i_T_Q_adjust,l_saturate_bkCloud,l_rtma3d,i_precip_vertical_check, & - corp_howv, hwllp_howv + corp_howv, hwllp_howv, corp_gust, hwllp_gust, oerr_gust ! chem(options for gsi chem analysis) : ! berror_chem - .true. when background for chemical species that require diff --git a/src/gsi/m_berror_stats_reg.f90 b/src/gsi/m_berror_stats_reg.f90 index 8730e56c3b..d7a30808e6 100644 --- a/src/gsi/m_berror_stats_reg.f90 +++ b/src/gsi/m_berror_stats_reg.f90 @@ -313,6 +313,7 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt use mpeu_util,only: getindex use radiance_mod, only: icloud_cv,n_clouds_fwd,cloud_names_fwd use chemmod, only: berror_fv3_cmaq_regional,berror_fv3_sd_regional + use rapidrefresh_cldsurf_mod, only: corp_gust, hwllp_gust, l_rtma3d implicit none @@ -825,11 +826,35 @@ subroutine berror_read_wgt_reg(msig,mlat,corz,corp,hwll,hwllp,vz,rlsig,varq,qopt ! end if else if (n==nrf2_gust) then do i=1,mlat - corp(i,n)=three + corp(i,n)=three ! background error stddev of wind gust = 3 m/s (default: legacy code from 2DRTMA) end do do i=0,mlat+1 - hwllp(i,n)=hwll(i,1,nrf3_q) + hwllp(i,n)=hwll(i,1,nrf3_q) ! de-correlation length of bkgd error of gust is + ! same as the value of q at bottom level (default: legacy code from 2DRTMA) + ! for other DA apps, it is recommended to change it + ! by setting hwllp_gust in GSI namelist. end do + if ( l_rtma3d ) then ! For 3drtma only: allowing to change the stddev and + ! de-correlation length of bkgd error of gust: + ! corp_gust : set in namelist(if <=0, using default value above (3.0) + ! hwllp_gust: set in namelist(if <=0, using default value above (value of q) + if ( corp_gust .gt. 0.0_r_kind ) then + corp(1:mlat, n) = corp_gust + if (mype==0) write(6,'(1x,A,A,I5.5,A,F8.3)') & + myname_,"@pe=",mype," (3drtma) set b_error stddev of gust = ",corp_gust + else + if (mype==0) write(6,'(1x,A,A,I5.5,A,F8.3)') & + myname_,"@pe=",mype," (3drtma) set b_error stddev of gust (default) = ",three + end if + if ( hwllp_gust .gt. 0.0_r_kind ) then + hwllp(0:mlat+1,n) = hwllp_gust + if (mype==0) write(6,'(1x,A,A,I5.5,A,F12.3)') & + myname_,"@pe=",mype," (3drtma) set b_error de-corr length of gust = ",hwllp_gust + else + if (mype==0) write(6,'(1x,A,A,I5.5,A)') & + myname_,"@pe=",mype," (3drtma) set b_error de-corr length of gust is same as length of q." + end if + end if else if (n==nrf2_vis) then do i=1,mlat corp(i,n)=3.0_r_kind diff --git a/src/gsi/rapidrefresh_cldsurf_mod.f90 b/src/gsi/rapidrefresh_cldsurf_mod.f90 index 122d2872d0..475f44a9d3 100644 --- a/src/gsi/rapidrefresh_cldsurf_mod.f90 +++ b/src/gsi/rapidrefresh_cldsurf_mod.f90 @@ -197,6 +197,30 @@ module rapidrefresh_cldsurf_mod ! just the reduced static BE of howv. If to make the analysis of howv ! in hyrbid run is as similar as the analysis of howv in pure 3dvar run, ! the static BE of howv used in hybrid run needs to be tuned (inflated actually). +! corp_gust - namelist real, static BE of gust (standard error deviation) +! note: 1. initialised to be an arbitary negative value, in order to skip this +! negative value, instead to use value (3.0 m/s) set in subroutine +! berror_read_wgt_reg as default. +! 2. (3drtma only) if a user-specified value (e.g., 2.0 m/s) is preferred +! for corp_gust, in GSI namelist session "rapidrefresh_cldsurf", +! set "corp_gust=2.0," +! hwllp_gust - namelist real, static BE de-correlation length scale of gust +! note: 1. initialised to be an arbitary negative value, in order to skip this +! negative value, instead to use value (same value for q) set in +! subroutine berror_read_wgt_reg as default +! 2. (3drtma only) if a user-specified value (e.g., 100 km) is preferred +! for hwllp_gust, in GSI namelist session "rapidrefresh_cldsurf", +! set "hwllp_gust=100000.0," +! oerr_gust - namelist real, observation error of gust +! note: 1. initialised to be an arbitary negative value, in order to skip this +! negative value, instead to use value (1.0 m/s) set in read_prepbufr.f90 +! 2. (3drtma only) if a user-specified value (e.g., 1.5 m/s ) is preferred +! for oerr_gust, in GSI namelist session "rapidrefresh_cldsurf", +! set "oerr_gust=1.5," +! i_gust_3dda - integer, control the analysis of gust in 3D analysis (either var or hybrid) +! = 0 (gust-off: default) : no analysis of gust in 3D analysis. +! = 1 (gust-on) : if variable name "gust" is found in anavinfo, +! set it to be 1 to turn on analysis of gust; ! ! attributes: ! language: f90 @@ -270,6 +294,8 @@ module rapidrefresh_cldsurf_mod public :: i_precip_vertical_check public :: corp_howv, hwllp_howv public :: i_howv_3dda + public :: corp_gust, hwllp_gust, oerr_gust + public :: i_gust_3dda logical l_hydrometeor_bkio real(r_kind) dfi_radar_latent_heat_time_period @@ -330,6 +356,8 @@ module rapidrefresh_cldsurf_mod integer(i_kind) i_precip_vertical_check real(r_kind) :: corp_howv, hwllp_howv integer(i_kind) :: i_howv_3dda + real(r_kind) :: corp_gust, hwllp_gust, oerr_gust + integer(i_kind) :: i_gust_3dda contains @@ -447,6 +475,22 @@ subroutine init_rapidrefresh_cldsurf corp_howv = 0.42_r_kind ! 0.42 meters (default) hwllp_howv = 170000.0_r_kind ! 170,000.0 meters (170km as default for 3DRTMA, 50km is used in 2DRTMA) i_howv_3dda = 0 ! no analysis of significant wave height (howv) in 3D analysis (default) + corp_gust = -1.50_r_kind ! initialised as negative & void to be skipped, in order to use + ! the value (3.0 m/s) set in sub berror_read_wgt_reg (as default). + ! If user-specified value is preferred, set it in session + ! "rapidrefresh_cldsurf" of GSI namelist file + + hwllp_gust = -90000.0_r_kind ! initialised as a value, in order to skip this negative value + ! and to use the value (used for q) set in sub berror_read_wgt_reg. + ! If user-specified value is preferred, set it in session + ! "rapidrefresh_cldsurf" of GSI namelist file + + oerr_gust = -2.5_r_kind ! initialised as a negative value, in order to skip this negative value + ! and to use the value (1.0 m/s) set in read_prepbufr.f90 + ! If user-specified value is preferred, set it in session + ! "rapidrefresh_cldsurf" of GSI namelist file + + i_gust_3dda = 0 ! no analysis of wind gust (gust) in 3D analysis (default) !-- searching for specific variable in state variable list (reading from anavinfo) do i2=1,ns2d @@ -456,6 +500,12 @@ subroutine init_rapidrefresh_cldsurf write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_howv_3dda = ", i_howv_3dda end if end if + if ( trim(svars2d(i2))=='gust' .or. trim(svars2d(i2))=='GUST' ) then + i_gust_3dda = 1 + if ( mype == 0 ) then + write(6,'(1x,A,1x,A8,1x,A,1x,I4)')"init_rapidrefresh_cldsurf: anavinfo svars2d (state variable): ",trim(adjustl(svars2d(i2))), " is found in anavinfo, set i_gust_3dda = ", i_gust_3dda + end if + end if end do ! i2 : looping over 2-D anasv return diff --git a/src/gsi/read_prepbufr.f90 b/src/gsi/read_prepbufr.f90 index f281573a4e..bed3b31db2 100644 --- a/src/gsi/read_prepbufr.f90 +++ b/src/gsi/read_prepbufr.f90 @@ -227,7 +227,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& use adjust_cloudobs_mod, only: adjust_convcldobs,adjust_goescldobs use mpimod, only: npe use rapidrefresh_cldsurf_mod, only: i_gsdsfc_uselist,i_gsdqc,i_ens_mean - use rapidrefresh_cldsurf_mod, only: l_rtma3d + use rapidrefresh_cldsurf_mod, only: l_rtma3d, oerr_gust use gsi_io, only: verbose use phil2, only: denest ! hilbert curve @@ -1825,6 +1825,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& gustqm=0 if (kx==188 .or. kx==288 .or. kx==195 .or. kx==295 ) & call get_gustqm(kx,c_station_id,c_prvstg,c_sprvstg,gustqm) + if ( l_rtma3d ) gustqm = 0 ! skipping get_gustqm for 3drtma run (missing list file) qm=gustqm else if(visob) then visqm=0 ! need to fix this later @@ -2556,6 +2557,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& ! need to find out gustoe ! gustoe=1.8 gustoe=1.0 + if ( l_rtma3d .and. oerr_gust > 0.0_r_kind ) gustoe = oerr_gust selev=stnelev oelev=obsdat(4,k) if(selev == oelev)oelev=r10+selev @@ -2577,6 +2579,7 @@ subroutine read_prepbufr(nread,ndata,nodata,infile,obstype,lunout,twindin,sis,& if ((kx==188).or.(kx==288) .or.(kx==195) .or.(kx==295)) then ! gustoe=2.5 gustoe=1.0 + if ( l_rtma3d .and. oerr_gust > 0.0_r_kind ) gustoe = oerr_gust windcorr=abs(obsdat(5,k))<1.0 .and. abs(obsdat(6,k))<1.0 .and. obsdat(8,k)>10.0 if (windcorr) gustoe=gustoe*1.5_r_kind From d75f44a34419e719e78cc2fb21b33fcfa428ada7 Mon Sep 17 00:00:00 2001 From: Andrew Collard <40322596+ADCollard@users.noreply.github.com> Date: Thu, 18 Apr 2024 14:30:17 -0400 Subject: [PATCH 23/35] Two small tweaks to thinning (#734) This PR addresses GSI #731. It modifies the satthin.F90 routine to allow data to be processed unthinned in the GSI without requiring exorbitant resources and it removes an unnecessary thinning from the read_atms.f90 routine. The change to satthin reduces the value of `itxmax` from 1.e9 to 1.e7 which should be sufficient for most sensors. But if a larger number is required for a sensor, this may be passed in via optional argument. This change will change results for ATMS only as documented in the issue. --- src/gsi/read_atms.f90 | 5 ----- src/gsi/satthin.F90 | 11 ++++++++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/gsi/read_atms.f90 b/src/gsi/read_atms.f90 index c6ed159068..424843a7c1 100644 --- a/src/gsi/read_atms.f90 +++ b/src/gsi/read_atms.f90 @@ -544,11 +544,6 @@ subroutine read_atms(mype,val_tovs,ithin,isfcalc,& dlat_earth = dlat_earth*deg2rad dlon_earth = dlon_earth*deg2rad -! Just use every fifth scan position and scanline (and make sure that we have -! position 48 as we need it for scan bias) - if (5*NINT(REAL(IScan(Iob))/5_r_kind) /= IScan(IOb) .OR. & - 5*NINT(REAL(IFov-3)/5_r_kind) /= IFOV -3 ) CYCLE ObsLoop - ! Regional case if(regional)then call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside) diff --git a/src/gsi/satthin.F90 b/src/gsi/satthin.F90 index 93f193014f..c093c4b1d5 100644 --- a/src/gsi/satthin.F90 +++ b/src/gsi/satthin.F90 @@ -350,7 +350,7 @@ subroutine makegvals end subroutine makegvals - subroutine makegrids(rmesh,ithin,n_tbin) + subroutine makegrids(rmesh,ithin,n_tbin,itxmax_in) !$$$ subprogram documentation block ! . . . . ! subprogram: makegrids @@ -386,7 +386,8 @@ subroutine makegrids(rmesh,ithin,n_tbin) real(r_kind) ,intent(in ) :: rmesh integer(i_kind),intent(in ) :: ithin - integer(i_kind),intent(in ), optional :: n_tbin + integer(i_kind),intent(in ), optional :: n_tbin + integer(i_kind),intent(in ), optional :: itxmax_in real(r_kind),parameter:: r360 = 360.0_r_kind integer(i_kind) i,j integer(i_kind) mlonx,mlonj @@ -402,7 +403,11 @@ subroutine makegrids(rmesh,ithin,n_tbin) itx_all=0 if(abs(rmesh) <= one .or. ithin <= 0)then use_all=.true. - itxmax=1e9 + if (present(itxmax_in)) then + itxmax = itxmax_in + else + itxmax = 1e7 + endif allocate(icount(itxmax)) allocate(score_crit(itxmax)) do j=1,itxmax From 457510c72e486b7b01db09e5b1a6f407778dc772 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Mon, 22 Apr 2024 09:16:16 -0400 Subject: [PATCH 24/35] reorder correlated error setup checks (#736) --- src/gsi/correlated_obsmod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/gsi/correlated_obsmod.F90 b/src/gsi/correlated_obsmod.F90 index 7a14cd3226..17cd94efe1 100644 --- a/src/gsi/correlated_obsmod.F90 +++ b/src/gsi/correlated_obsmod.F90 @@ -961,14 +961,18 @@ subroutine upd_varch_ enddo nchanl1=jc - if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov') if(.not.amiset_(GSI_BundleErrorCov(itbl))) then - if (iamroot_) write(6,*) 'WARNING: Error Covariance not set for ',trim(idnames(itbl)) + if (iamroot_) write(6,*) trim(myname_), ' WARNING: Error Covariance not set for ',trim(idnames(itbl)) cycle read_tab endif nch_active=GSI_BundleErrorCov(itbl)%nch_active - if(nch_active<0) return + if(nch_active<0) then + if (iamroot_) write(6,*) trim(myname_), ' WARNING: No active channels for ',trim(idnames(itbl)) + return + endif + + if(nchanl1==0) call die(myname_,' improperly set GSI_BundleErrorCov') if(GMAO_ObsErrorCov)then do jj=1,nch_active From 8e279f9c734097f673b07e80f385b2623d13ba4a Mon Sep 17 00:00:00 2001 From: Innocent Souopgui <162634017+InnocentSouopgui-NOAA@users.noreply.github.com> Date: Thu, 25 Apr 2024 14:45:32 -0500 Subject: [PATCH 25/35] Update Jet modulefiles to Rocky8 (#733) - Update Jet module file to use Rocky8 installation of spack-stack; --- modulefiles/gsi_jet.intel.lua | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/modulefiles/gsi_jet.intel.lua b/modulefiles/gsi_jet.intel.lua index cc43e98260..48189ba241 100644 --- a/modulefiles/gsi_jet.intel.lua +++ b/modulefiles/gsi_jet.intel.lua @@ -1,7 +1,7 @@ help([[ ]]) -prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") +prepend_path("MODULEPATH", "/mnt/lfs4/HFIP/hfv3gfs/role.epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev-rocky8/install/modulefiles/Core") local python_ver=os.getenv("python_ver") or "3.11.6" local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.5.0" From 8a85d7c9dcc4b63e1792fda75ca9a405f3ba9dc2 Mon Sep 17 00:00:00 2001 From: James Jung Date: Mon, 29 Apr 2024 14:35:25 -0400 Subject: [PATCH 26/35] Add _CLDDET.NL to fix and activate CADS in global_4denvar ctest (#740) --- fix | 2 +- regression/global_4denvar.sh | 4 ++++ regression/regression_namelists.sh | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/fix b/fix index 92de100c4d..a801d5cf07 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit 92de100c4d5893e9d6409afbdda6937b0de1cb3b +Subproject commit a801d5cf07c3955e71258a0c8e9b074bb0f03fe4 diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 056815228b..177ce0f8a9 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -128,6 +128,8 @@ errtable=$fixgsi/prepobs_errtable.global aeroinfo=$fixgsi/global_aeroinfo.txt atmsbeaminfo=$fixgsi/atms_beamwidth.txt cloudyinfo=$fixgsi/cloudy_radiance_info.txt +cris_clddet=$fixgsi/CRIS_CLDDET.NL +iasi_clddet=$fixgsi/IASI_CLDDET.NL emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin @@ -169,6 +171,8 @@ $ncp $errtable ./errtable $ncp $aeroinfo ./aeroinfo $ncp $atmsbeaminfo ./atms_beamwidth.txt $ncp $cloudyinfo ./cloudy_radiance_info.txt +$ncp $cris_clddet ./CRIS_CLDDET.NL +$ncp $iasi_clddet ./IASI_CLDDET.NL $ncp $bufrtable ./prepobs_prep.bufrtable $ncp $bftab_sst ./bftab_sstphr diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 552bc1ba59..620f776526 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -68,7 +68,7 @@ export gsi_namelist=" dfact=0.75,dfact1=3.0,noiqc=.true.,oberrflg=.false.,c_varqc=0.04, use_poq7=.true.,qc_noirjaco3_pole=.true.,vqc=.false.,nvqc=.true.,hub_norm=.true., aircraft_t_bc=.true.,biaspredt=1.0e5,upd_aircraft=.true.,cleanup_tail=.true., - tcp_width=70.0,tcp_ermax=7.35, + tcp_width=70.0,tcp_ermax=7.35,cris_cads=.true.,iasi_cads=.true., $OBSQC / &OBS_INPUT From a3a26336dcf4de3bac4afe8fbe790947e51af4db Mon Sep 17 00:00:00 2001 From: ShunLiu-NOAA Date: Mon, 29 Apr 2024 22:45:49 -0400 Subject: [PATCH 27/35] nread bug in read_radar.f90 (#738) In read_radar.f90, the value of nread should be "nsuper2_kept" and shouldn't be reset to zero after processing TDR data. - [x] Bug fix (non-breaking change which fixes an issue) --- src/gsi/read_radar.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/gsi/read_radar.f90 b/src/gsi/read_radar.f90 index a824bbbe4e..84a4f4fbcf 100644 --- a/src/gsi/read_radar.f90 +++ b/src/gsi/read_radar.f90 @@ -907,6 +907,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu end do superobs close(lnbufr) ! A simple unformatted fortran file should not be mixed with a bufr I/O + nread=nsuper2_kept LEVEL_TWO_READ_2: if(loop==0 .and. sis=='l2rw') then write(6,*)'READ_RADAR: ',trim(outmessage),' reached eof on 2/2.5/3 superob radar file' @@ -2176,7 +2177,6 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu ibadstaheight=0 notgood=0 notgood0=0 - nread=0 ntdrvr_in=0 ntdrvr_kept=0 ntdrvr_thin1=0 @@ -2522,7 +2522,7 @@ subroutine read_radar(nread,ndata,nodata,infile,lunout,obstype,twind,sis,hgtl_fu end do ! end of loop, reading TDR so data files close(lnbufr) - else + else if (trim(infile) == 'tldplrbufr' ) then nswptype=0 nmrecs=0 From 38bdb95640b72fb335092857680dd2f16e29940e Mon Sep 17 00:00:00 2001 From: Wei Huang Date: Tue, 7 May 2024 06:53:54 -0600 Subject: [PATCH 28/35] Add module file to compile on AWS (#742) --- modulefiles/gsi_noaacloud.intel.lua | 25 +++++++++++++++++++++++++ ush/module-setup.sh | 4 ++++ 2 files changed, 29 insertions(+) create mode 100644 modulefiles/gsi_noaacloud.intel.lua diff --git a/modulefiles/gsi_noaacloud.intel.lua b/modulefiles/gsi_noaacloud.intel.lua new file mode 100644 index 0000000000..e2e019628e --- /dev/null +++ b/modulefiles/gsi_noaacloud.intel.lua @@ -0,0 +1,25 @@ +help([[ +]]) + +prepend_path("MODULEPATH", "/contrib/spack-stack/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") + +local python_ver=os.getenv("python_ver") or "3.10.13" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.3.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.3.0" +local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" + +load(pathJoin("stack-intel", stack_intel_ver)) +load(pathJoin("stack-intel-oneapi-mpi", stack_impi_ver)) +load(pathJoin("python", python_ver)) +load(pathJoin("cmake", cmake_ver)) + +load("gsi_common") +load(pathJoin("prod_util", prod_util_ver)) + +pushenv("CFLAGS", "-xHOST") +pushenv("FFLAGS", "-xHOST") + +pushenv("GSI_BINARY_SOURCE_DIR", "/contrib/Wei.Huang/data/hack-orion/fix/gsi/20240208") + +whatis("Description: GSI environment on NOAA Cloud with Intel Compilers") diff --git a/ush/module-setup.sh b/ush/module-setup.sh index c1893ab4ee..f587842f0f 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -75,6 +75,10 @@ elif [[ $MACHINE_ID = discover* ]]; then export PATH=$PATH:$SPACK_ROOT/bin . $SPACK_ROOT/share/spack/setup-env.sh +elif [[ $MACHINE_ID = noaacloud* ]]; then + # We are on NOAA Cloud + module purge + else echo WARNING: UNKNOWN PLATFORM 1>&2 fi From ebeaba1eced0ec7aa33a588e838e1aca20933230 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 7 May 2024 21:31:58 -0400 Subject: [PATCH 29/35] add license (#745) --- LICENSE.md | 157 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 157 insertions(+) create mode 100644 LICENSE.md diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000000..0927556b54 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,157 @@ +### GNU LESSER GENERAL PUBLIC LICENSE + +Version 3, 29 June 2007 + +Copyright (C) 2007 Free Software Foundation, Inc. + + +Everyone is permitted to copy and distribute verbatim copies of this +license document, but changing it is not allowed. + +This version of the GNU Lesser General Public License incorporates the +terms and conditions of version 3 of the GNU General Public License, +supplemented by the additional permissions listed below. + +#### 0. Additional Definitions. + +As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the +GNU General Public License. + +"The Library" refers to a covered work governed by this License, other +than an Application or a Combined Work as defined below. + +An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + +A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + +The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + +The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + +#### 1. Exception to Section 3 of the GNU GPL. + +You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + +#### 2. Conveying Modified Versions. + +If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + +- a) under this License, provided that you make a good faith effort + to ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or +- b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + +#### 3. Object Code Incorporating Material from Library Header Files. + +The object code form of an Application may incorporate material from a +header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + +- a) Give prominent notice with each copy of the object code that + the Library is used in it and that the Library and its use are + covered by this License. +- b) Accompany the object code with a copy of the GNU GPL and this + license document. + +#### 4. Combined Works. + +You may convey a Combined Work under terms of your choice that, taken +together, effectively do not restrict modification of the portions of +the Library contained in the Combined Work and reverse engineering for +debugging such modifications, if you also do each of the following: + +- a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. +- b) Accompany the Combined Work with a copy of the GNU GPL and this + license document. +- c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. +- d) Do one of the following: + - 0) Convey the Minimal Corresponding Source under the terms of + this License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + - 1) Use a suitable shared library mechanism for linking with + the Library. A suitable mechanism is one that (a) uses at run + time a copy of the Library already present on the user's + computer system, and (b) will operate properly with a modified + version of the Library that is interface-compatible with the + Linked Version. +- e) Provide Installation Information, but only if you would + otherwise be required to provide such information under section 6 + of the GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the Application + with a modified version of the Linked Version. (If you use option + 4d0, the Installation Information must accompany the Minimal + Corresponding Source and Corresponding Application Code. If you + use option 4d1, you must provide the Installation Information in + the manner specified by section 6 of the GNU GPL for conveying + Corresponding Source.) + +#### 5. Combined Libraries. + +You may place library facilities that are a work based on the Library +side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + +- a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities, conveyed under the terms of this License. +- b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + +#### 6. Revised Versions of the GNU Lesser General Public License. + +The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +as you received it specifies that a certain numbered version of the +GNU Lesser General Public License "or any later version" applies to +it, you have the option of following the terms and conditions either +of that published version or of any later version published by the +Free Software Foundation. If the Library as you received it does not +specify a version number of the GNU Lesser General Public License, you +may choose any version of the GNU Lesser General Public License ever +published by the Free Software Foundation. + +If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. From 59d7578b31454140cb38bf65b27e3cffb02c7e3e Mon Sep 17 00:00:00 2001 From: DavidBurrows-NCO <82525974+DavidBurrows-NCO@users.noreply.github.com> Date: Mon, 20 May 2024 11:51:45 -0400 Subject: [PATCH 30/35] Update module files to build gsi on Gaea-C5 (#746) --- modulefiles/gsi_gaea.intel.lua | 26 ++++++++------------------ regression/regression_param.sh | 34 +++++++++++++++++----------------- regression/regression_var.sh | 16 ++++++---------- ush/module-setup.sh | 4 +--- ush/sub_gaea | 12 ++++++------ 5 files changed, 38 insertions(+), 54 deletions(-) diff --git a/modulefiles/gsi_gaea.intel.lua b/modulefiles/gsi_gaea.intel.lua index 96643202a7..799822caa8 100644 --- a/modulefiles/gsi_gaea.intel.lua +++ b/modulefiles/gsi_gaea.intel.lua @@ -1,18 +1,13 @@ help([[ ]]) -unload("intel") -unload("cray-mpich") -unload("cray-python") -unload("darshan") +prepend_path("MODULEPATH", "/ncrc/proj/epic/spack-stack/spack-stack-1.6.0/envs/gsi-addon-dev/install/modulefiles/Core") -prepend_path("MODULEPATH", "/lustre/f2/dev/wpo/role.epic/contrib/spack-stack/spack-stack-1.4.1-c4/envs/unified-env/install/modulefiles/Core") -prepend_path("MODULEPATH", "/lustre/f2/pdata/esrl/gsd/spack-stack/modulefiles") - -local stack_python_ver=os.getenv("stack_python_ver") or "3.9.12" -local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" -local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "7.7.20" +local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2023.1.0" +local stack_cray_mpich_ver=os.getenv("stack_cray_mpich_ver") or "8.1.25" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" +local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" load(pathJoin("stack-intel", stack_intel_ver)) load(pathJoin("stack-cray-mpich", stack_cray_mpich_ver)) @@ -20,23 +15,18 @@ load(pathJoin("stack-python", stack_python_ver)) load(pathJoin("cmake", cmake_ver)) load("gsi_common") - -local prod_util_ver=os.getenv("prod_util_ver") or "1.2.2" -load(pathJoin("prod-util", prod_util_ver)) - --- Needed at runtime: -load("alps") +load(pathJoin("prod_util", prod_util_ver)) local MKLROOT="/opt/intel/oneapi/mkl/2022.0.2/" prepend_path("LD_LIBRARY_PATH",pathJoin(MKLROOT,"lib/intel64")) pushenv("MKLROOT", MKLROOT) -pushenv("GSI_BINARY_SOURCE_DIR", "/lustre/f2/dev/role.epic/contrib/GSI_data/fix/20240208") +pushenv("GSI_BINARY_SOURCE_DIR", "/gpfs/f5/ufs-ard/world-shared/GSI_data/fix/gsi/20240208") setenv("CC","cc") setenv("FC","ftn") setenv("CXX","CC") pushenv("CRAYPE_LINK_TYPE","dynamic") +unload("cray-libsci") whatis("Description: GSI environment on Gaea with Intel Compilers") - diff --git a/regression/regression_param.sh b/regression/regression_param.sh index a4f5d7035c..6ee72f14da 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -26,8 +26,8 @@ case $machine in ;; Gaea) sub_cmd="sub_gaea" - memnode=64 - numcore=36 + memnode=251 + numcore=128 ;; wcoss2) sub_cmd="sub_wcoss2" @@ -69,8 +69,8 @@ case $regtest in topts[1]="0:30:00" ; popts[1]="48/2" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="60/3" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="18/8/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="18/10/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="12/8/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/10/" ; ropts[2]="/2" @@ -99,8 +99,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -129,8 +129,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -158,8 +158,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="18/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="18/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="128/2/" ; ropts[2]="/1" @@ -188,8 +188,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" @@ -218,8 +218,8 @@ case $regtest in topts[1]="0:30:00" ; popts[1]="6/12/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="8/12/" ; ropts[2]="/1" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:30:00" ; popts[1]="8/6/" ; ropts[1]="/1" - topts[2]="0:30:00" ; popts[2]="8/8/" ; ropts[2]="/1" + topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" + topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:30:00" ; popts[1]="14/8/" ; ropts[1]="/1" topts[2]="0:30:00" ; popts[2]="14/14/" ; ropts[2]="/2" @@ -248,8 +248,8 @@ case $regtest in topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" elif [[ "$machine" = "Gaea" ]]; then - topts[1]="0:10:00" ; popts[1]="12/3/" ; ropts[1]="/1" - topts[2]="0:10:00" ; popts[2]="12/5/" ; ropts[2]="/2" + topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" + topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" elif [[ "$machine" = "wcoss2" ]]; then topts[1]="0:10:00" ; popts[1]="16/2/" ; ropts[1]="/1" topts[2]="0:10:00" ; popts[2]="16/4/" ; ropts[2]="/2" @@ -315,7 +315,7 @@ elif [[ "$machine" = "Gaea" ]]; then export MPI_BUFS_PER_PROC=256 export MPI_BUFS_PER_HOST=256 export MPI_GROUP_MAX=256 - export APRUN="srun --export=ALL --mpi=pmi2 -n \$ntasks" + export APRUN="srun --export=ALL -n \$ntasks" elif [[ "$machine" = "wcoss2" ]]; then export OMP_PLACES=cores export OMP_STACKSIZE=2G diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 315028675c..aebbccab8b 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -36,7 +36,7 @@ elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet export machine="Jet" elif [[ -d /discover ]]; then # NCCS Discover export machine="Discover" -elif [[ -d /sw/gaea ]]; then # Gaea +elif [[ -d /ncrc ]]; then # Gaea export machine="Gaea" elif [[ -d /data/prod ]]; then # S4 export machine="S4" @@ -52,17 +52,13 @@ echo "Running Regression Tests on '$machine'"; case $machine in Gaea) export queue="normal" - export noscrub="/lustre/f2/scratch/$LOGNAME/gsi_tmp/noscrub" - export ptmp="/lustre/f2/scratch/$LOGNAME/gsi_tmp/ptmp" - export casesdir="/lustre/f2/dev/role.epic/contrib/GSI_data/CASES/regtest" - - export group="global" - if [[ "$cmaketest" = "false" ]]; then - export basedir="/lustre/f2/dev/$LOGNAME/sandbox/GSI" - fi + export group="ufs-ard" + export noscrub="/gpfs/f5/${group}/scratch/${USER}/$LOGNAME/gsi_tmp/noscrub" + export ptmp="/gpfs/f5/${group}/scratch/${USER}/$LOGNAME/gsi_tmp/ptmp" + export casesdir="/gpfs/f5/ufs-ard/world-shared/GSI_data/CASES/regtest" export check_resource="no" - export accnt="nggps_emc" + export accnt="ufs-ard" ;; wcoss2) export local_or_default="${local_or_default:-/lfs/h2/emc/da/noscrub/$LOGNAME}" diff --git a/ush/module-setup.sh b/ush/module-setup.sh index f587842f0f..299e13aa4e 100755 --- a/ush/module-setup.sh +++ b/ush/module-setup.sh @@ -56,10 +56,8 @@ elif [[ $MACHINE_ID = gaea* ]] ; then # the module command fails. Hence we actually have to source # /etc/profile here. source /etc/profile - __ms_source_etc_profile=yes fi - - source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh + module reset elif [[ $MACHINE_ID = expanse* ]]; then # We are on SDSC Expanse diff --git a/ush/sub_gaea b/ush/sub_gaea index afad6aa7ab..9c4e253c93 100755 --- a/ush/sub_gaea +++ b/ush/sub_gaea @@ -88,8 +88,8 @@ output=${output:-$jobname.out} myuser=$LOGNAME myhost=$(hostname) -if [ -d /lustre/f2/scratch/$LOGNAME ]; then - DATA=/lustre/f2/scratch/$LOGNAME/tmp +if [ -d /gpfs/f5/epic/scratch/${USER}/$LOGNAME ]; then + DATA=/gpfs/f5/epic/scratch/${USER}/$LOGNAME/tmp fi DATA=${DATA:-$ptmp/tmp} @@ -110,7 +110,7 @@ echo "" echo "#SBATCH --output=$output" >> $cfile echo "#SBATCH --job-name=$jobname" >> $cfile echo "#SBATCH --qos=$queue" >> $cfile -echo "#SBATCH --clusters=c4" >> $cfile +echo "#SBATCH --clusters=c5" >> $cfile echo "#SBATCH --time=$timew" >> $cfile echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --cpus-per-task=$threads" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile @@ -121,13 +121,13 @@ echo "export ntasks=$(( $nodes * $procs ))" >> $cfile echo "export ppn=$procs" >> $cfile echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile -echo "ulimit -s unlimited" >> $cfile +echo "ulimit -s unlimited" >> $cfile echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile -echo "source /lustre/f2/dev/role.epic/contrib/Lmod_init.sh" >> $cfile +echo "module reset" >> $cfile echo "module use $modulefiles" >> $cfile echo "module load gsi_gaea.intel" >> $cfile echo "module list" >> $cfile @@ -158,7 +158,7 @@ sbatch=${sbatch:-sbatch} ofile=$DATA/subout$$ >$ofile chmod 777 $ofile -$sbatch --export=ALL $cfile >$ofile +$sbatch $cfile >$ofile rc=$? cat $ofile if [[ -w $SUBLOG ]];then From f82dc3405704d0022c20b200f053272e9bbb3383 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Fri, 21 Jun 2024 10:01:21 -0400 Subject: [PATCH 31/35] add two band sdl to global_4denvar namelist (#758) --- regression/regression_namelists.sh | 6 ++++-- regression/regression_namelists_db.sh | 9 ++++++--- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index 620f776526..d360dfd870 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -195,10 +195,12 @@ OBS_INPUT:: / &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8, + l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false., generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192, - ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false.,readin_localization=.true., + ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false., ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false., + s_ens_h=1000.0,450.0,685.0,s_ens_v=-0.5,-0.5,0.0,readin_localization=.false., + global_spectral_filter_sd=.false.,r_ensloccov4scl=1,nsclgrp=2,naensloc=3, $HYBRID_ENSEMBLE / &RAPIDREFRESH_CLDSURF diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index e03917e888..83718b50d5 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -174,9 +174,12 @@ OBS_INPUT:: $LAGDATA / &HYBRID_ENSEMBLE - l_hyb_ens=.true.,n_ens=10,beta_s0=0.125,readin_beta=.false.,s_ens_h=800,s_ens_v=-0.8,generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=190, - nlat_ens=194,nlon_ens=384,aniso_a_en=.false.,jcap_ens_test=62,oz_univ_static=.false.,readin_localization=.true.,ensemble_path='./ensemble_data/', - ens_fast_read=.true.,write_ens_sprd=.false., + l_hyb_ens=.true.,n_ens=$NMEM_ENKF,beta_s0=0.125,readin_beta=.false., + generate_ens=.false.,uv_hyb_ens=.true.,jcap_ens=48,nlat_ens=98,nlon_ens=192, + ANISO_A_EN=.false.,jcap_ens_test=48,oz_univ_static=.false., + ensemble_path='./ensemble_data/',ens_fast_read=.true.,write_ens_sprd=.false., + s_ens_h=1000.0,450.0,685.0,s_ens_v=-0.5,-0.5,0.0,readin_localization=.false., + global_spectral_filter_sd=.false.,r_ensloccov4scl=1,nsclgrp=2,naensloc=3, $HYBRID_ENSEMBLE / &RAPIDREFRESH_CLDSURF From 6a87460bd9d116d3e4b0ceadc565f66496443636 Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Tue, 25 Jun 2024 08:12:01 -0400 Subject: [PATCH 32/35] update path to global ctest model data (#762) --- regression/global_4denvar.sh | 6 +++--- regression/global_enkf.sh | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/regression/global_4denvar.sh b/regression/global_4denvar.sh index 177ce0f8a9..945200eb66 100755 --- a/regression/global_4denvar.sh +++ b/regression/global_4denvar.sh @@ -61,7 +61,7 @@ suffix=tm00.bufr_d dumpges=gdas COMROOTgfs=$casesdir/gfs/prod datobs=$COMROOTgfs/$dumpobs.$PDYa/${cyca}/obs -dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model_data/atmos/history +dathis=$COMROOTgfs/$dumpges.$PDYg/${cycg}/model/atmos/history datanl=$COMROOTgfs/gdas.$PDYg/${cycg}/analysis/atmos datens=$COMROOTgfs/enkfgdas.$PDYg/${cycg} @@ -291,7 +291,7 @@ $nln $dathis/${prefix_ges}.atmf007.nc ./sigf07 $nln $dathis/${prefix_ges}.atmf008.nc ./sigf08 $nln $dathis/${prefix_ges}.atmf009.nc ./sigf09 -$nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid +$nln $datens/ensstat/model/atmos/history/${prefix_ens}.sfcf006.ensmean.nc ./sfcf06_anlgrid export ENS_PATH='./ensemble_data/' mkdir -p ${ENS_PATH} @@ -301,7 +301,7 @@ for fh in $flist; do imem=1 while [[ $imem -le $NMEM_ENKF ]]; do member="mem"`printf %03i $imem` - $nln $datens/$member/model_data/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member} + $nln $datens/$member/model/atmos/history/$sigens ${ENS_PATH}sigf${fh}_ens_${member} (( imem = $imem + 1 )) done done diff --git a/regression/global_enkf.sh b/regression/global_enkf.sh index ca40abda52..a35f8d109f 100755 --- a/regression/global_enkf.sh +++ b/regression/global_enkf.sh @@ -163,13 +163,13 @@ nfhrs=`echo $IAUFHRS_ENKF | sed 's/,/ /g'` for fhr in $nfhrs; do for imem in $(seq 1 $NMEM_ENKF); do memchar="mem"$(printf %03i $imem) - $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model/atmos/history/${prefix_ens}.atmf00${fhr}.nc sfg_${global_adate}_fhr0${fhr}_${memchar} if [ $cnvw_option = ".true." ]; then - $nln $datens/$memchar/model_data/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} + $nln $datens/$memchar/model/atmos/history/${prefix_ens}sfcf00${fhr}.nc sfgsfc_${global_adate}_fhr0${fhr}_${memchar} fi (( imem = $imem + 1 )) done - $nln $datens/ensstat/model_data/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean + $nln $datens/ensstat/model/atmos/history/${prefix_ens}.atmf00${fhr}.ensmean.nc sfg_${global_adate}_fhr0${fhr}_ensmean if [ $cnvw_option = ".true." ]; then $nln $datens/${prefix_ens}.sfcf00${fhr}.ensmean.nc sfgsfc_${global_adate}_fhr0${fhr}_ensmean fi From 24b731a6c6574bd93586bedd694bac7ac60cd7b8 Mon Sep 17 00:00:00 2001 From: Ming Hu Date: Thu, 27 Jun 2024 08:11:01 -0400 Subject: [PATCH 33/35] Update RRFS regression test cases (#750) 1) Change RRFS case from rrfs_3denvar_glbens to rrfs_3denvar_rdasens. The new RRFS case has the same configuration as RRFS_A warm cycles. 2) delete case netcdf_fv3_regional 3) add RRFS EnKF case for conventional observations: rrfs_enkf_conv --- fix | 2 +- regression/CMakeLists.txt | 14 +- regression/multi_regression.sh | 8 +- regression/netcdf_fv3_regional.sh | 207 ------------ regression/regression_driver.sh | 2 +- regression/regression_namelists.sh | 302 ++++++++++-------- regression/regression_namelists_db.sh | 190 +++-------- regression/regression_param.sh | 24 +- regression/regression_test_enkf.sh | 99 ++++-- regression/regression_var.sh | 14 +- ...nvar_glbens.sh => rrfs_3denvar_rdasens.sh} | 181 +++++++++-- regression/rrfs_enkf_conv.sh | 223 +++++++++++++ 12 files changed, 708 insertions(+), 558 deletions(-) delete mode 100755 regression/netcdf_fv3_regional.sh rename regression/{rrfs_3denvar_glbens.sh => rrfs_3denvar_rdasens.sh} (55%) create mode 100755 regression/rrfs_enkf_conv.sh diff --git a/fix b/fix index a801d5cf07..15ffa60307 160000 --- a/fix +++ b/fix @@ -1 +1 @@ -Subproject commit a801d5cf07c3955e71258a0c8e9b074bb0f03fe4 +Subproject commit 15ffa60307bbc19746d8caeb41782de0b7604be6 diff --git a/regression/CMakeLists.txt b/regression/CMakeLists.txt index 99d92162e6..e36cca605b 100644 --- a/regression/CMakeLists.txt +++ b/regression/CMakeLists.txt @@ -40,14 +40,20 @@ endif() list(APPEND GSI_REG_TEST_NAMES global_4denvar rtma - rrfs_3denvar_glbens netcdf_fv3_regional + rrfs_3denvar_rdasens hafs_4denvar_glbens hafs_3denvar_hybens ) # EnKF regression test names -list(APPEND ENKF_REG_TEST_NAMES - global_enkf -) +if(ENKF_MODE MATCHES "^(FV3REG)$") + list(APPEND ENKF_REG_TEST_NAMES + rrfs_enkf_conv + ) +else() + list(APPEND ENKF_REG_TEST_NAMES + global_enkf + ) +endif() # Add GSI regression tests to list of tests if(GSICONTROLEXEC) diff --git a/regression/multi_regression.sh b/regression/multi_regression.sh index 4df5581097..d01492aa44 100755 --- a/regression/multi_regression.sh +++ b/regression/multi_regression.sh @@ -1,16 +1,16 @@ #!/bin/sh --login regtests_all="global_4denvar - netcdf_fv3_regional - rrfs_3denvar_glbens + rrfs_3denvar_rdasens hafs_4denvar_glbens hafs_3denvar_hybens rtma global_enkf" +# rrfs_enkf_conv : comment out RRFS enkf case for now +# need to update EnKF code regtests_debug="global_4denvar - netcdf_fv3_regional - rrfs_3denvar_glbens + rrfs_3denvar_rdasens hafs_4denvar_glbens hafs_3denvar_hybens rtma diff --git a/regression/netcdf_fv3_regional.sh b/regression/netcdf_fv3_regional.sh deleted file mode 100755 index e6188f51c6..0000000000 --- a/regression/netcdf_fv3_regional.sh +++ /dev/null @@ -1,207 +0,0 @@ - -set -x - -# Set analysis date -#adate=2015061000 - -# Set experiment name -exp=$jobname - -# Set runtime and save directories -tmpdir=$tmpdir/tmpreg_netcdf_fv3_regional/${exp} -savdir=$savdir/outreg_netcdf_fv3_regional/${exp} - -# Set variables used in script -# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) -# ncp is cp replacement, currently keep as /bin/cp - -UNCOMPRESS=gunzip -CLEAN=NO -ncp=/bin/cp - - -# Set up $tmpdir -rm -rf $tmpdir -mkdir -p $tmpdir -chgrp rstprod $tmpdir -chmod 750 $tmpdir -cd $tmpdir - -#FIXnam=/da/save/Michael.Lueken/trunk/fix -fixcrtm=${fixcrtm:-$CRTM_FIX} - -berror=$fixgsi/nam_nmm_berror.f77.gcv -anavinfo=$fixgsi/anavinfo_fv3 - - -# Make gsi namelist - -. $scripts/regression_nl_update.sh - -SETUP="$SETUP_update" -GRIDOPTS="$GRIDOPTS_update" -BKGVERR="$BKGVERR_update" -ANBKGERR="$ANBKERR_update" -JCOPTS="$JCOPTS_update" -STRONGOPTS="$STRONGOPTS_update" -OBSQC="$OBSQC_update" -OBSINPUT="$OBSINPUT_update" -SUPERRAD="$SUPERRAD_update" -HYBRID_ENSEMBLE='ensemble_path="",' -SINGLEOB="$SINGLEOB_update" - -if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh netcdf_fv3_regional -else - . $scripts/regression_namelists_db.sh netcdf_fv3_regional -fi - -# dmesh(1)=120.0,time_window_max=1.5,ext_sonde=.true., - -cat << EOF > gsiparm.anl - -$gsi_namelist - -EOF - -emiscoef_IRwater=$fixcrtm/Nalli.IRwater.EmisCoeff.bin -emiscoef_IRice=$fixcrtm/NPOESS.IRice.EmisCoeff.bin -emiscoef_IRland=$fixcrtm/NPOESS.IRland.EmisCoeff.bin -emiscoef_IRsnow=$fixcrtm/NPOESS.IRsnow.EmisCoeff.bin -emiscoef_VISice=$fixcrtm/NPOESS.VISice.EmisCoeff.bin -emiscoef_VISland=$fixcrtm/NPOESS.VISland.EmisCoeff.bin -emiscoef_VISsnow=$fixcrtm/NPOESS.VISsnow.EmisCoeff.bin -emiscoef_VISwater=$fixcrtm/NPOESS.VISwater.EmisCoeff.bin -emiscoef_MWwater=$fixcrtm/FASTEM6.MWwater.EmisCoeff.bin -aercoef=$fixcrtm/AerosolCoeff.bin -cldcoef=$fixcrtm/CloudCoeff.bin -satinfo=$fixgsi/nam_regional_satinfo.txt -cloudyinfo=$fixgsi/cloudy_radiance_info.txt -scaninfo=$fixgsi/global_scaninfo.txt -pcpinfo=$fixgsi/nam_global_pcpinfo.txt -ozinfo=$fixgsi/nam_global_ozinfo.txt -errtable=$fixgsi/nam_errtable.r3dv -convinfo=$fixgsi/nam_regional_convinfo.txt -mesonetuselist=$fixgsi/nam_mesonet_uselist.txt -stnuselist=$fixgsi/nam_mesonet_stnuselist.txt -qdaylist=$fixgsi/rtma_q_day_rejectlist -qnightlist=$fixgsi/rtma_q_night_rejectlist -tdaylist=$fixgsi/rtma_t_day_rejectlist -tnightlist=$fixgsi/rtma_t_night_rejectlist -wbinuselist=$fixgsi/rtma_wbinuselist -locinfo=$fixgsi/nam_hybens_d01_locinfo -### add 9 tables -errtable_pw=$fixgsi/prepobs_errtable_pw.global -errtable_ps=$fixgsi/prepobs_errtable_ps.global_nqcf -errtable_t=$fixgsi/prepobs_errtable_t.global_nqcf -errtable_q=$fixgsi/prepobs_errtable_q.global_nqcf -errtable_uv=$fixgsi/prepobs_errtable_uv.global_nqcf -btable_ps=$fixgsi/nqc_b_ps.global_nqcf -btable_t=$fixgsi/nqc_b_t.global_nqcf -btable_q=$fixgsi/nqc_b_q.global_nqcf -btable_uv=$fixgsi/nqc_b_uv.global_nqcf - -# add vertical profile of localization and beta_s,beta_e weights for hybrid ensemble runs -hybens_info=$fixgsi/nam_hybens_d01_info - - -# Copy executable and fixed files to $tmpdir -if [[ $exp == *"updat"* ]]; then - $ncp $gsiexec_updat ./gsi.x -elif [[ $exp == *"contrl"* ]]; then - $ncp $gsiexec_contrl ./gsi.x -fi - -cp $anavinfo ./anavinfo -cp $berror ./berror_stats -cp $errtable ./errtable -cp $emiscoef_IRwater ./Nalli.IRwater.EmisCoeff.bin -cp $emiscoef_IRice ./NPOESS.IRice.EmisCoeff.bin -cp $emiscoef_IRsnow ./NPOESS.IRsnow.EmisCoeff.bin -cp $emiscoef_IRland ./NPOESS.IRland.EmisCoeff.bin -cp $emiscoef_VISice ./NPOESS.VISice.EmisCoeff.bin -cp $emiscoef_VISland ./NPOESS.VISland.EmisCoeff.bin -cp $emiscoef_VISsnow ./NPOESS.VISsnow.EmisCoeff.bin -cp $emiscoef_VISwater ./NPOESS.VISwater.EmisCoeff.bin -cp $emiscoef_MWwater ./FASTEM6.MWwater.EmisCoeff.bin -cp $aercoef ./AerosolCoeff.bin -cp $cldcoef ./CloudCoeff.bin -cp $satinfo ./satinfo -cp $cloudyinfo ./cloudy_radiance_info.txt -cp $scaninfo ./scaninfo -cp $pcpinfo ./pcpinfo -cp $ozinfo ./ozinfo -cp $convinfo ./convinfo -cp $mesonetuselist ./mesonetuselist -cp $stnuselist ./mesonet_stnuselist -cp $qdaylist ./q_day_rejectlist -cp $qnightlist ./q_night_rejectlist -cp $tdaylist ./t_day_rejectlist -cp $tnightlist ./t_night_rejectlist -cp $wbinuselist ./wbinuselist -#cp $locinfo ./hybens_info -#add 9 tables for new varqc -$ncp $errtable_pw ./errtable_pw -$ncp $errtable_ps ./errtable_ps -$ncp $errtable_t ./errtable_t -$ncp $errtable_q ./errtable_q -$ncp $errtable_uv ./errtable_uv -$ncp $btable_ps ./btable_ps -$ncp $btable_t ./btable_t -$ncp $btable_q ./btable_q -$ncp $btable_uv ./btable_uv - -$ncp $hybens_info ./hybens_info - - -###### crtm coeff's ####################### -set +x -for file in `awk '{if($1!~"!"){print $1}}' satinfo | sort | uniq` ;do - cp $fixcrtm/${file}.SpcCoeff.bin ./ - cp $fixcrtm/${file}.TauCoeff.bin ./ -done -set -x - -PDY=`echo $adate | cut -c1-8` -CYC=`echo $adate | cut -c9-10` - -#datdir=/meso/noscrub/Wanshu.Wu/CASE/$adate - -cp $fv3_netcdf_obs/ndas.t06z.radwnd.tm06.bufr_d ./radarbufr -cp $fv3_netcdf_obs/ndas.t06z.prepbufr.tm06 ./prepbufr -cp $fv3_netcdf_obs/ndas.t06z.1bamua.tm06.bufr_d ./amsuabufr -cp $fv3_netcdf_obs/ndas.t06z.1bmhs.tm06.bufr_d ./mhsbufr -cp $fv3_netcdf_obs/ndas.t06z.goesfv.tm06.bufr_d ./gsnd1bufr -cp $fv3_netcdf_obs/ndas.t06z.airsev.tm06.bufr_d ./airsbufr -cp $fv3_netcdf_obs/ndas.t06z.satwnd.tm06.bufr_d ./satwndbufr - -cp $fv3_netcdf_ges/coupler.res coupler.res -cp $fv3_netcdf_ges/fv_core.res.nest02.nc fv3_akbk -cp $fv3_netcdf_ges/grid_spec.nest02.nc fv3_grid_spec -#the current GSI parallel IO for fv3-lam require the netcdf 4 format for nc files containing 3d fields -nccopy -4 $fv3_netcdf_ges/fv_core.res.nest02.tile7.nc fv3_dynvars -nccopy -4 $fv3_netcdf_ges/fv_tracer.res.nest02.tile7.nc fv3_tracer -cp $fv3_netcdf_ges/sfc_data.nest02.tile7.nc fv3_sfcdata - - -cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc -cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in -cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas - -listdiag=`tar xvf radstat.gdas | cut -d' ' -f2 | grep _ges` -for type in $listdiag; do - diag_file=`echo $type | cut -d',' -f1` - fname=`echo $diag_file | cut -d'.' -f1` - date=`echo $diag_file | cut -d'.' -f2` - $UNCOMPRESS $diag_file - fnameanl=$(echo $fname|sed 's/_ges//g') - mv $fname.$date $fnameanl -done - - -# Run GSI -cd $tmpdir -echo "run gsi now" -eval "$APRUN $tmpdir/gsi.x > stdout 2>&1" -rc=$? -exit $rc diff --git a/regression/regression_driver.sh b/regression/regression_driver.sh index 38329778a4..805a9dd1fb 100755 --- a/regression/regression_driver.sh +++ b/regression/regression_driver.sh @@ -59,7 +59,7 @@ if [ "$debug" == ".false." ]; then export scripts=${scripts_updat:-$scripts} - if [ $regtest = 'global_enkf' ]; then + if [ $regtest = 'global_enkf' ] || [ $regtest = 'rrfs_enkf_conv' ]; then /bin/sh $scripts/regression_test_enkf.sh ${job[1]} ${job[2]} ${job[3]} ${job[4]} ${tmpregdir} ${result} ${scaling[1]} ${scaling[2]} ${scaling[3]} else /bin/sh $scripts/regression_test.sh ${job[1]} ${job[2]} ${job[3]} ${job[4]} ${tmpregdir} ${result} ${scaling[1]} ${scaling[2]} ${scaling[3]} diff --git a/regression/regression_namelists.sh b/regression/regression_namelists.sh index d360dfd870..a4f283f92b 100755 --- a/regression/regression_namelists.sh +++ b/regression/regression_namelists.sh @@ -319,7 +319,7 @@ OBS_INPUT:: / " ;; - rrfs_3denvar_glbens) + rrfs_3denvar_rdasens) # Define namelist for rrfs 3d hybrid envar run with global ensembles @@ -328,13 +328,14 @@ export gsi_namelist=" &SETUP miter=2,niter(1)=5,niter(2)=5, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2,print_obs_para=.true.,diag_radardbz=.false., - if_model_dbz=.false., static_gsi_nopcp_dbz=0.0, + qoption=2,print_obs_para=.true.,diag_fed=.true.,diag_radardbz=.false., + if_model_dbz=.true.,if_model_fed=.true.,static_gsi_nopcp_dbz=0.0,if_use_w_vr=.false., rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0, - missing_to_nopcp=.false.,radar_no_thinning=.true., + inflate_dbz_obserr=.true.,missing_to_nopcp=.false.,radar_no_thinning=.true., gencode=78,factqmin=0.0,factqmax=0.0, - iguess=-1, + iguess=-1,crtm_coeffs_path='./', lread_obs_save=.false.,lread_obs_skip=.false., + ens_nstarthr=01, oneobtest=.false.,retrieval=.false., nhr_assimilation=3,l_foto=.false., use_pbl=.false.,use_prepb_satwnd=.false., @@ -343,8 +344,10 @@ export gsi_namelist=" diag_precon=.true.,step_start=1.e-3, l4densvar=.false.,nhr_obsbin=3, use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true., - netcdf_diag=.false.,binary_diag=.true., + netcdf_diag=.true.,binary_diag=.false., l_obsprvdiag=.false., + lwrite_peakwt=.true., + innov_use_model_fed=.true., / &GRIDOPTS fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20, @@ -372,7 +375,9 @@ export gsi_namelist=" / OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc + pm25bufr pm2_5 null TEOM 1.0 0 0 dbzobs.nc dbz null dbz 1.0 0 0 + fedobs.nc fed null fed 1.0 0 0 prepbufr ps null ps 1.0 0 0 prepbufr t null t 1.0 0 0 prepbufr q null q 1.0 0 0 @@ -389,6 +394,12 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -397,12 +408,14 @@ OBS_INPUT:: amsuabufr amsua n19 amsua_n19 0.0 2 0 amsuabufr amsua metop-a amsua_metop-a 0.0 2 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + amsuabufr amsua metop-c amsua_metop-c 0.0 2 0 airsbufr amsua aqua amsua_aqua 0.0 2 0 amsubbufr amsub n17 amsub_n17 0.0 1 0 mhsbufr mhs n18 mhs_n18 0.0 2 0 mhsbufr mhs n19 mhs_n19 0.0 2 0 mhsbufr mhs metop-a mhs_metop-a 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 2 0 + mhsbufr mhs metop-c mhs_metop-c 0.0 2 0 ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 @@ -431,11 +444,23 @@ OBS_INPUT:: gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0 iasibufr iasi metop-a iasi_metop-a 0.0 2 0 gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 2 0 + seviribufr seviri m09 seviri_m09 0.0 2 0 + seviribufr seviri m10 seviri_m10 0.0 2 0 + seviribufr seviri m11 seviri_m11 0.0 2 0 + iasibufr iasi metop-b iasi_metop-b 0.0 2 0 + iasibufr iasi metop-c iasi_metop-c 0.0 2 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 atmsbufr atms npp atms_npp 0.0 2 0 atmsbufr atms n20 atms_n20 0.0 2 0 + atmsbufr atms n21 atms_n21 0.0 2 0 crisbufr cris npp cris_npp 0.0 2 0 crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0 crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0 + crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 2 0 abibufr abi g16 abi_g16 0.0 2 0 mlsbufr mls30 aura mls30_aura 0.0 0 0 oscatbufr uv null uv 0.0 0 0 @@ -444,6 +469,7 @@ OBS_INPUT:: refInGSI rad_ref null rad_ref 1.0 0 0 lghtInGSI lghtn null lghtn 1.0 0 0 larcInGSI larccld null larccld 1.0 0 0 + abibufr abi g18 abi_g18 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false., @@ -456,17 +482,30 @@ OBS_INPUT:: q_hyb_ens=.false., aniso_a_en=.false.,generate_ens=.false., n_ens=${nummem}, - beta_s0=0.15,s_ens_h=110,s_ens_v=3, - regional_ensemble_option=1, + l_both_fv3sar_gfs_ens=.false.,n_ens_gfs=0,n_ens_fv3sar=30, + weight_ens_gfs=1.0,weight_ens_fv3sar=1.0, + beta_s0=0.15,s_ens_h=328.632,82.1580,4.10790,4.10790,82.1580,s_ens_v=3,3,-0.30125,-0.30125,0.0, + regional_ensemble_option=5, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, jcap_ens=574, fv3sar_bg_opt=0, - readin_localization=.true., - ens_fast_read=.false., + readin_localization=.false., + parallelization_over_ensmembers=.false., + nsclgrp=2,l_timloc_opt=.false.,ngvarloc=2,naensloc=5, + r_ensloccov4tim=1.0,r_ensloccov4var=0.05,r_ensloccov4scl=1.0, + global_spectral_filter_sd=.false.,assign_vdl_nml=.false.,vdl_scale=0, + vloc_varlist(1,1)='sf ',vloc_varlist(2,1)='w ',vloc_varlist(3,1)='sf ',vloc_varlist(4,1)='w ', + vloc_varlist(1,2)='vp ',vloc_varlist(2,2)='qr ',vloc_varlist(3,2)='vp ',vloc_varlist(4,2)='qr ', + vloc_varlist(1,3)='ps ',vloc_varlist(2,3)='qs ',vloc_varlist(3,3)='ps ',vloc_varlist(4,3)='qs ', + vloc_varlist(1,4)='t ',vloc_varlist(2,4)='qi ',vloc_varlist(3,4)='t ',vloc_varlist(4,4)='qi ', + vloc_varlist(1,5)='q ',vloc_varlist(2,5)='qg ',vloc_varlist(3,5)='q ',vloc_varlist(4,5)='qg ', + vloc_varlist(1,6)='sst',vloc_varlist(2,6)='ql ',vloc_varlist(3,6)='sst',vloc_varlist(4,6)='ql ', + vloc_varlist(1,7)='stl',vloc_varlist(2,7)='dbz',vloc_varlist(3,7)='stl',vloc_varlist(4,7)='dbz', + vloc_varlist(1,8)='sti',vloc_varlist(2,8)='aaa',vloc_varlist(3,8)='sti',vloc_varlist(4,8)='aaa', / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, @@ -506,6 +545,8 @@ OBS_INPUT:: i_gsdqc=2, / &CHEM + laeroana_fv3smoke=.false., + berror_fv3_cmaq_regional=.false., / &NST / @@ -516,6 +557,7 @@ OBS_INPUT:: / " ;; + hafs_envar) # Define namelist for hafs 3denvar run with global ensembles export gsi_namelist=" @@ -777,130 +819,128 @@ SUPEROB_RADAR:: / " ;; - netcdf_fv3_regional) + rrfs_enkf_conv) -# Define namelist for netcdf fv3 run +# Define namelist for rrfs EnKF run export gsi_namelist=" - &SETUP - miter=2,niter(1)=5,niter(2)=5,niter_no_qc(1)=2, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - newpc4pred=.true., adp_anglebc=.true., angord=4, - diag_precon=.true., step_start=1.e-3, - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false.,gpstop=30., - lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - fv3_regional=.true.,grid_ratio_fv3_regional=3.0, - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false., - / - &JCOPTS - / - &STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02, - vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - gpsrobufr gps_bnd null gps_bnd 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs281_aqua 0.0 1 0 - msubufr msu n14 msu_n14 0.0 1 0 - amsuabufr amsua n15 amsua_n15 0.0 1 0 - amsuabufr amsua n16 amsua_n16 0.0 1 0 - amsuabufr amsua n17 amsua_n17 0.0 1 0 - amsuabufr amsua n18 amsua_n18 0.0 1 0 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 - airsbufr amsua aqua amsua_aqua 0.0 1 0 - amsubbufr amsub n15 amsub_n15 0.0 1 0 - amsubbufr amsub n16 amsub_n16 0.0 1 0 - amsubbufr amsub n17 amsub_n17 0.0 1 0 - mhsbufr mhs n18 mhs_n18 0.0 1 0 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - ssmitbufr ssmi f13 ssmi_f13 0.0 1 0 - ssmitbufr ssmi f14 ssmi_f14 0.0 1 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 0 - gomebufr gome metop-a gome_metop-a 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - omibufr omi aura omi_aura 0.0 1 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - amsuabufr amsua n19 amsua_n19 0.0 1 0 - mhsbufr mhs n19 mhs_n19 0.0 1 0 - tcvitl tcp null tcp 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - atmsbufr atms npp atms_npp 0.0 1 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - prepbufr mta_cld null mta_cld 1.0 0 0 - prepbufr gos_ctp null gos_ctp 1.0 0 0 - lgycldbufr larccld null larccld 1.0 0 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - / - &NST - / + &nam_enkf + datestring=${rrfs_enkf_adate},datapath='${tmpdir}/', + analpertwtnh=1.10,analpertwtsh=1.10,analpertwttr=1.10, + covinflatemax=1.e2,covinflatemin=1,pseudo_rh=.true.,iassim_order=0, + corrlengthnh=300,corrlengthsh=300,corrlengthtr=300, + lnsigcutoffnh=0.5,lnsigcutoffsh=0.5,lnsigcutofftr=0.5, + lnsigcutoffpsnh=0.5,lnsigcutoffpssh=0.5,lnsigcutoffpstr=0.5, + lnsigcutoffsatnh=0.5,lnsigcutoffsatsh=0.5,lnsigcutoffsattr=0.5, + obtimelnh=1.e30,obtimelsh=1.e30,obtimeltr=1.e30, + saterrfact=1.0,numiter=1, + sprd_tol=1.e30,paoverpb_thresh=0.98, + nlons=420,nlats= 252, nlevs= 65,nanals=5, + deterministic=.true.,sortinc=.true.,lupd_satbiasc=.false., + reducedgrid=.true.,readin_localization=.false., + use_gfs_nemsio=.true.,imp_physics=99,lupp=.false., + univaroz=.false.,adp_anglebc=.true.,angord=4,use_edges=.false.,emiss_bc=.true., + lobsdiag_forenkf=.false., + write_spread_diag=.false., + netcdf_diag=.true., + fv3_native=.true., + / + &satobs_enkf + sattypes_rad(1) = 'amsua_n15', dsis(1) = 'amsua_n15', + sattypes_rad(2) = 'amsua_n18', dsis(2) = 'amsua_n18', + sattypes_rad(3) = 'amsua_n19', dsis(3) = 'amsua_n19', + sattypes_rad(4) = 'amsub_n16', dsis(4) = 'amsub_n16', + sattypes_rad(5) = 'amsub_n17', dsis(5) = 'amsub_n17', + sattypes_rad(6) = 'amsua_aqua', dsis(6) = 'amsua_aqua', + sattypes_rad(7) = 'amsua_metop-a', dsis(7) = 'amsua_metop-a', + sattypes_rad(8) = 'airs_aqua', dsis(8) = 'airs_aqua', + sattypes_rad(9) = 'hirs3_n17', dsis(9) = 'hirs3_n17', + sattypes_rad(10)= 'hirs4_n19', dsis(10)= 'hirs4_n19', + sattypes_rad(11)= 'hirs4_metop-a', dsis(11)= 'hirs4_metop-a', + sattypes_rad(12)= 'mhs_n18', dsis(12)= 'mhs_n18', + sattypes_rad(13)= 'mhs_n19', dsis(13)= 'mhs_n19', + sattypes_rad(14)= 'mhs_metop-a', dsis(14)= 'mhs_metop-a', + sattypes_rad(15)= 'goes_img_g11', dsis(15)= 'imgr_g11', + sattypes_rad(16)= 'goes_img_g12', dsis(16)= 'imgr_g12', + sattypes_rad(17)= 'goes_img_g13', dsis(17)= 'imgr_g13', + sattypes_rad(18)= 'goes_img_g14', dsis(18)= 'imgr_g14', + sattypes_rad(19)= 'goes_img_g15', dsis(19)= 'imgr_g15', + sattypes_rad(20)= 'avhrr_n18', dsis(20)= 'avhrr3_n18', + sattypes_rad(21)= 'avhrr_metop-a', dsis(21)= 'avhrr3_metop-a', + sattypes_rad(22)= 'avhrr_n19', dsis(22)= 'avhrr3_n19', + sattypes_rad(23)= 'amsre_aqua', dsis(23)= 'amsre_aqua', + sattypes_rad(24)= 'ssmis_f16', dsis(24)= 'ssmis_f16', + sattypes_rad(25)= 'ssmis_f17', dsis(25)= 'ssmis_f17', + sattypes_rad(26)= 'ssmis_f18', dsis(26)= 'ssmis_f18', + sattypes_rad(27)= 'ssmis_f19', dsis(27)= 'ssmis_f19', + sattypes_rad(28)= 'ssmis_f20', dsis(28)= 'ssmis_f20', + sattypes_rad(29)= 'sndrd1_g11', dsis(29)= 'sndrD1_g11', + sattypes_rad(30)= 'sndrd2_g11', dsis(30)= 'sndrD2_g11', + sattypes_rad(31)= 'sndrd3_g11', dsis(31)= 'sndrD3_g11', + sattypes_rad(32)= 'sndrd4_g11', dsis(32)= 'sndrD4_g11', + sattypes_rad(33)= 'sndrd1_g12', dsis(33)= 'sndrD1_g12', + sattypes_rad(34)= 'sndrd2_g12', dsis(34)= 'sndrD2_g12', + sattypes_rad(35)= 'sndrd3_g12', dsis(35)= 'sndrD3_g12', + sattypes_rad(36)= 'sndrd4_g12', dsis(36)= 'sndrD4_g12', + sattypes_rad(37)= 'sndrd1_g13', dsis(37)= 'sndrD1_g13', + sattypes_rad(38)= 'sndrd2_g13', dsis(38)= 'sndrD2_g13', + sattypes_rad(39)= 'sndrd3_g13', dsis(39)= 'sndrD3_g13', + sattypes_rad(40)= 'sndrd4_g13', dsis(40)= 'sndrD4_g13', + sattypes_rad(41)= 'sndrd1_g14', dsis(41)= 'sndrD1_g14', + sattypes_rad(42)= 'sndrd2_g14', dsis(42)= 'sndrD2_g14', + sattypes_rad(43)= 'sndrd3_g14', dsis(43)= 'sndrD3_g14', + sattypes_rad(44)= 'sndrd4_g14', dsis(44)= 'sndrD4_g14', + sattypes_rad(45)= 'sndrd1_g15', dsis(45)= 'sndrD1_g15', + sattypes_rad(46)= 'sndrd2_g15', dsis(46)= 'sndrD2_g15', + sattypes_rad(47)= 'sndrd3_g15', dsis(47)= 'sndrD3_g15', + sattypes_rad(48)= 'sndrd4_g15', dsis(48)= 'sndrD4_g15', + sattypes_rad(49)= 'iasi_metop-a', dsis(49)= 'iasi_metop-a', + sattypes_rad(50)= 'seviri_m08', dsis(50)= 'seviri_m08', + sattypes_rad(51)= 'seviri_m09', dsis(51)= 'seviri_m09', + sattypes_rad(52)= 'seviri_m10', dsis(52)= 'seviri_m10', + sattypes_rad(53)= 'seviri_m11', dsis(53)= 'seviri_m11', + sattypes_rad(54)= 'amsua_metop-b', dsis(54)= 'amsua_metop-b', + sattypes_rad(55)= 'hirs4_metop-b', dsis(55)= 'hirs4_metop-b', + sattypes_rad(56)= 'mhs_metop-b', dsis(56)= 'mhs_metop-b', + sattypes_rad(57)= 'iasi_metop-b', dsis(57)= 'iasi_metop-b', + sattypes_rad(58)= 'avhrr_metop-b', dsis(58)= 'avhrr3_metop-b', + sattypes_rad(59)= 'atms_npp', dsis(59)= 'atms_npp', + sattypes_rad(60)= 'atms_n20', dsis(60)= 'atms_n20', + sattypes_rad(61)= 'cris_npp', dsis(61)= 'cris_npp', + sattypes_rad(62)= 'cris-fsr_npp', dsis(62)= 'cris-fsr_npp', + sattypes_rad(63)= 'cris-fsr_n20', dsis(63)= 'cris-fsr_n20', + sattypes_rad(64)= 'gmi_gpm', dsis(64)= 'gmi_gpm', + sattypes_rad(65)= 'saphir_meghat', dsis(65)= 'saphir_meghat', + sattypes_rad(66)= 'amsua_metop-c', dsis(66)= 'amsua_metop-c', + sattypes_rad(67)= 'mhs_metop-c', dsis(67)= 'mhs_metop-c', + sattypes_rad(68)= 'ahi_himawari8', dsis(68)= 'ahi_himawari8', + sattypes_rad(69)= 'abi_g16', dsis(69)= 'abi_g16', + sattypes_rad(70)= 'abi_g17', dsis(70)= 'abi_g17', + sattypes_rad(71)= 'iasi_metop-c', dsis(71)= 'iasi_metop-c', + sattypes_rad(72)= 'viirs-m_npp', dsis(72)= 'viirs-m_npp', + sattypes_rad(73)= 'viirs-m_j1', dsis(73)= 'viirs-m_j1', + sattypes_rad(74)= 'avhrr_metop-c', dsis(74)= 'avhrr3_metop-c', + sattypes_rad(75)= 'abi_g18', dsis(75)= 'abi_g18', + sattypes_rad(76)= 'ahi_himawari9', dsis(76)= 'ahi_himawari9', + sattypes_rad(77)= 'viirs-m_j2', dsis(77)= 'viirs-m_j2', + sattypes_rad(78)= 'atms_n21', dsis(78)= 'atms_n21', + sattypes_rad(79)= 'cris-fsr_n21', dsis(79)= 'cris-fsr_n21', + / + &ozobs_enkf + sattypes_oz(1) = 'sbuv2_n16', + sattypes_oz(2) = 'sbuv2_n17', + sattypes_oz(3) = 'sbuv2_n18', + sattypes_oz(4) = 'sbuv2_n19', + sattypes_oz(5) = 'omi_aura', + sattypes_oz(6) = 'gome_metop-a', + sattypes_oz(7) = 'gome_metop-b', + sattypes_oz(8) = 'mls30_aura', + / + &nam_fv3 + fv3fixpath="XXX",nx_res=${NX_RES:-420},ny_res=${NY_RES-252},ntiles=1, + l_fv3reg_filecombined=.false., + / " ;; global_enkf) diff --git a/regression/regression_namelists_db.sh b/regression/regression_namelists_db.sh index 83718b50d5..b96c208070 100755 --- a/regression/regression_namelists_db.sh +++ b/regression/regression_namelists_db.sh @@ -301,7 +301,7 @@ OBS_INPUT:: " ;; - rrfs_3denvar_glbens) + rrfs_3denvar_rdasens) # Define namelist for rrfs 3d hybrid envar run with global ensembles @@ -310,13 +310,14 @@ export gsi_namelist=" &SETUP miter=1,niter(1)=2,niter(2)=2, write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2,print_obs_para=.true.,diag_radardbz=.false., - if_model_dbz=.false., static_gsi_nopcp_dbz=0.0, + qoption=2,print_obs_para=.true.,diag_fed=.true.,diag_radardbz=.false., + if_model_dbz=.true.,if_model_fed=.true.,static_gsi_nopcp_dbz=0.0,if_use_w_vr=.false., rmesh_dbz=4.0,rmesh_vr=4.0,zmesh_dbz=1000.0,zmesh_vr=1000.0, - missing_to_nopcp=.false.,radar_no_thinning=.true., + inflate_dbz_obserr=.true.,missing_to_nopcp=.false.,radar_no_thinning=.true., gencode=78,factqmin=0.0,factqmax=0.0, - iguess=-1, + iguess=-1,crtm_coeffs_path='./', lread_obs_save=.false.,lread_obs_skip=.false., + ens_nstarthr=01, oneobtest=.false.,retrieval=.false., nhr_assimilation=3,l_foto=.false., use_pbl=.false.,use_prepb_satwnd=.false., @@ -325,8 +326,10 @@ export gsi_namelist=" diag_precon=.true.,step_start=1.e-3, l4densvar=.false.,nhr_obsbin=3, use_gfs_nemsio=.false.,use_gfs_ncio=.true.,reset_bad_radbc=.true., - netcdf_diag=.false.,binary_diag=.true., + netcdf_diag=.true.,binary_diag=.false., l_obsprvdiag=.false., + lwrite_peakwt=.true., + innov_use_model_fed=.true., / &GRIDOPTS fv3_regional=.true.,grid_ratio_fv3_regional=2.0,nvege_type=20, @@ -354,7 +357,9 @@ export gsi_namelist=" / OBS_INPUT:: ! dfile dtype dplat dsis dval dthin dsfcalc + pm25bufr pm2_5 null TEOM 1.0 0 0 dbzobs.nc dbz null dbz 1.0 0 0 + fedobs.nc fed null fed 1.0 0 0 prepbufr ps null ps 1.0 0 0 prepbufr t null t 1.0 0 0 prepbufr q null q 1.0 0 0 @@ -371,6 +376,12 @@ OBS_INPUT:: sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 + hirs3bufr hirs3 n16 hirs3_n16 0.0 1 0 + hirs3bufr hirs3 n17 hirs3_n17 0.0 1 0 + hirs4bufr hirs4 metop-a hirs4_metop-a 0.0 2 0 + hirs4bufr hirs4 n18 hirs4_n18 0.0 1 0 + hirs4bufr hirs4 n19 hirs4_n19 0.0 2 0 + hirs4bufr hirs4 metop-b hirs4_metop-b 0.0 2 0 gimgrbufr goes_img g11 imgr_g11 0.0 1 0 gimgrbufr goes_img g12 imgr_g12 0.0 1 0 airsbufr airs aqua airs_aqua 0.0 2 0 @@ -379,12 +390,14 @@ OBS_INPUT:: amsuabufr amsua n19 amsua_n19 0.0 2 0 amsuabufr amsua metop-a amsua_metop-a 0.0 2 0 amsuabufr amsua metop-b amsua_metop-b 0.0 2 0 + amsuabufr amsua metop-c amsua_metop-c 0.0 2 0 airsbufr amsua aqua amsua_aqua 0.0 2 0 amsubbufr amsub n17 amsub_n17 0.0 1 0 mhsbufr mhs n18 mhs_n18 0.0 2 0 mhsbufr mhs n19 mhs_n19 0.0 2 0 mhsbufr mhs metop-a mhs_metop-a 0.0 2 0 mhsbufr mhs metop-b mhs_metop-b 0.0 2 0 + mhsbufr mhs metop-c mhs_metop-c 0.0 2 0 ssmitbufr ssmi f13 ssmi_f13 0.0 2 0 ssmitbufr ssmi f14 ssmi_f14 0.0 2 0 ssmitbufr ssmi f15 ssmi_f15 0.0 2 0 @@ -413,11 +426,23 @@ OBS_INPUT:: gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 2 0 iasibufr iasi metop-a iasi_metop-a 0.0 2 0 gomebufr gome metop-a gome_metop-a 0.0 2 0 + omibufr omi aura omi_aura 0.0 2 0 + sbuvbufr sbuv2 n19 sbuv8_n19 0.0 0 0 + tcvitl tcp null tcp 0.0 0 0 + seviribufr seviri m08 seviri_m08 0.0 2 0 + seviribufr seviri m09 seviri_m09 0.0 2 0 + seviribufr seviri m10 seviri_m10 0.0 2 0 + seviribufr seviri m11 seviri_m11 0.0 2 0 + iasibufr iasi metop-b iasi_metop-b 0.0 2 0 + iasibufr iasi metop-c iasi_metop-c 0.0 2 0 + gomebufr gome metop-b gome_metop-b 0.0 2 0 atmsbufr atms npp atms_npp 0.0 2 0 atmsbufr atms n20 atms_n20 0.0 2 0 + atmsbufr atms n21 atms_n21 0.0 2 0 crisbufr cris npp cris_npp 0.0 2 0 crisfsbufr cris-fsr npp cris-fsr_npp 0.0 2 0 crisfsbufr cris-fsr n20 cris-fsr_n20 0.0 2 0 + crisfsbufr cris-fsr n21 cris-fsr_n21 0.0 2 0 abibufr abi g16 abi_g16 0.0 2 0 mlsbufr mls30 aura mls30_aura 0.0 0 0 oscatbufr uv null uv 0.0 0 0 @@ -426,6 +451,7 @@ OBS_INPUT:: refInGSI rad_ref null rad_ref 1.0 0 0 lghtInGSI lghtn null lghtn 1.0 0 0 larcInGSI larccld null larccld 1.0 0 0 + abibufr abi g18 abi_g18 0.0 2 0 :: &SUPEROB_RADAR del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., l2superob_only=.false., @@ -438,17 +464,30 @@ OBS_INPUT:: q_hyb_ens=.false., aniso_a_en=.false.,generate_ens=.false., n_ens=${nummem}, - beta_s0=0.15,s_ens_h=110,s_ens_v=3, - regional_ensemble_option=1, + l_both_fv3sar_gfs_ens=.false.,n_ens_gfs=0,n_ens_fv3sar=30, + weight_ens_gfs=1.0,weight_ens_fv3sar=1.0, + beta_s0=0.15,s_ens_h=328.632,82.1580,4.10790,4.10790,82.1580,s_ens_v=3,3,-0.30125,-0.30125,0.0, + regional_ensemble_option=5, pseudo_hybens = .false., - grid_ratio_ens = 3, + grid_ratio_ens = 1, l_ens_in_diff_time=.true., ensemble_path='', i_en_perts_io=1, jcap_ens=574, fv3sar_bg_opt=0, - readin_localization=.true., - ens_fast_read=.false., + readin_localization=.false., + parallelization_over_ensmembers=.false., + nsclgrp=2,l_timloc_opt=.false.,ngvarloc=2,naensloc=5, + r_ensloccov4tim=1.0,r_ensloccov4var=0.05,r_ensloccov4scl=1.0, + global_spectral_filter_sd=.false.,assign_vdl_nml=.false.,vdl_scale=0, + vloc_varlist(1,1)='sf ',vloc_varlist(2,1)='w ',vloc_varlist(3,1)='sf ',vloc_varlist(4,1)='w ', + vloc_varlist(1,2)='vp ',vloc_varlist(2,2)='qr ',vloc_varlist(3,2)='vp ',vloc_varlist(4,2)='qr ', + vloc_varlist(1,3)='ps ',vloc_varlist(2,3)='qs ',vloc_varlist(3,3)='ps ',vloc_varlist(4,3)='qs ', + vloc_varlist(1,4)='t ',vloc_varlist(2,4)='qi ',vloc_varlist(3,4)='t ',vloc_varlist(4,4)='qi ', + vloc_varlist(1,5)='q ',vloc_varlist(2,5)='qg ',vloc_varlist(3,5)='q ',vloc_varlist(4,5)='qg ', + vloc_varlist(1,6)='sst',vloc_varlist(2,6)='ql ',vloc_varlist(3,6)='sst',vloc_varlist(4,6)='ql ', + vloc_varlist(1,7)='stl',vloc_varlist(2,7)='dbz',vloc_varlist(3,7)='stl',vloc_varlist(4,7)='dbz', + vloc_varlist(1,8)='sti',vloc_varlist(2,8)='aaa',vloc_varlist(3,8)='sti',vloc_varlist(4,8)='aaa', / &RAPIDREFRESH_CLDSURF dfi_radar_latent_heat_time_period=20.0, @@ -488,6 +527,8 @@ OBS_INPUT:: i_gsdqc=2, / &CHEM + laeroana_fv3smoke=.false., + berror_fv3_cmaq_regional=.false., / &NST / @@ -761,133 +802,6 @@ SUPEROB_RADAR:: obhourset=0., / " -;; - - netcdf_fv3_regional) - -# Define namelist for netcdf fv3 run - -export gsi_namelist=" - - &SETUP - miter=2,niter(1)=2,niter(2)=1,niter_no_qc(1)=1, - write_diag(1)=.true.,write_diag(2)=.false.,write_diag(3)=.true., - qoption=2, - factqmin=0.0,factqmax=0.0,deltim=$DELTIM, - iguess=-1, - newpc4pred=.true., adp_anglebc=.true., angord=4, - diag_precon=.true., step_start=1.e-3, - nhr_assimilation=3,l_foto=.false., - use_pbl=.false.,use_compress=.false.,gpstop=30., - lrun_subdirs=.true., - $SETUP - / - &GRIDOPTS - fv3_regional=.true.,grid_ratio_fv3_regional=3.0, - / - &BKGERR - hzscl=0.373,0.746,1.50, - vs=0.6,bw=0.,fstat=.false., - / - &ANBKGERR - anisotropic=.false., - / - &JCOPTS - / - &STRONGOPTS - / - &OBSQC - dfact=0.75,dfact1=3.0,noiqc=.true.,c_varqc=0.02, - vadfile='prepbufr',oberrflg=.false.,njqc=.false.,vqc=.true., - / - &OBS_INPUT - dmesh(1)=120.0,dmesh(2)=60.0,dmesh(3)=60.0,dmesh(4)=60.0,dmesh(5)=120,time_window_max=1.5,ext_sonde=.true., - / -OBS_INPUT:: -! dfile dtype dplat dsis dval dthin dsfcalc - prepbufr ps null ps 0.0 0 0 - prepbufr t null t 0.0 0 0 - prepbufr q null q 0.0 0 0 - prepbufr pw null pw 0.0 0 0 - prepbufr uv null uv 0.0 0 0 - prepbufr spd null spd 0.0 0 0 - prepbufr dw null dw 0.0 0 0 - radarbufr rw null rw 0.0 0 0 - prepbufr sst null sst 0.0 0 0 - gpsrobufr gps_bnd null gps_bnd 0.0 0 0 - ssmirrbufr pcp_ssmi dmsp pcp_ssmi 0.0 -1 0 - tmirrbufr pcp_tmi trmm pcp_tmi 0.0 -1 0 - sbuvbufr sbuv2 n16 sbuv8_n16 0.0 0 0 - sbuvbufr sbuv2 n17 sbuv8_n17 0.0 0 0 - sbuvbufr sbuv2 n18 sbuv8_n18 0.0 0 0 - gsndrbufr sndr g11 sndr_g11 0.0 1 0 - gsndrbufr sndr g12 sndr_g12 0.0 1 0 - gimgrbufr goes_img g11 imgr_g11 0.0 1 0 - gimgrbufr goes_img g12 imgr_g12 0.0 1 0 - airsbufr airs aqua airs281_aqua 0.0 1 0 - msubufr msu n14 msu_n14 0.0 1 0 - amsuabufr amsua n15 amsua_n15 0.0 1 0 - amsuabufr amsua n16 amsua_n16 0.0 1 0 - amsuabufr amsua n17 amsua_n17 0.0 1 0 - amsuabufr amsua n18 amsua_n18 0.0 1 0 - amsuabufr amsua metop-a amsua_metop-a 0.0 1 0 - amsuabufr amsua metop-b amsua_metop-b 0.0 1 0 - airsbufr amsua aqua amsua_aqua 0.0 1 0 - amsubbufr amsub n15 amsub_n15 0.0 1 0 - amsubbufr amsub n16 amsub_n16 0.0 1 0 - amsubbufr amsub n17 amsub_n17 0.0 1 0 - mhsbufr mhs n18 mhs_n18 0.0 1 0 - mhsbufr mhs metop-a mhs_metop-a 0.0 1 0 - mhsbufr mhs metop-b mhs_metop-b 0.0 1 0 - ssmitbufr ssmi f13 ssmi_f13 0.0 1 0 - ssmitbufr ssmi f14 ssmi_f14 0.0 1 0 - ssmitbufr ssmi f15 ssmi_f15 0.0 1 0 - amsrebufr amsre_low aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_mid aqua amsre_aqua 0.0 1 0 - amsrebufr amsre_hig aqua amsre_aqua 0.0 1 0 - ssmisbufr ssmis f16 ssmis_f16 0.0 1 0 - iasibufr iasi metop-a iasi_metop-a 0.0 1 0 - gomebufr gome metop-a gome_metop-a 0.0 1 0 - iasibufr iasi metop-b iasi_metop-b 0.0 1 0 - omibufr omi aura omi_aura 0.0 1 0 - sbuvbufr sbuv2 n19 sbuv8_n19 0.0 1 0 - amsuabufr amsua n19 amsua_n19 0.0 1 0 - mhsbufr mhs n19 mhs_n19 0.0 1 0 - tcvitl tcp null tcp 0.0 0 0 - satwndbufr uv null uv 0.0 0 0 - atmsbufr atms npp atms_npp 0.0 1 0 - crisbufr cris npp cris_npp 0.0 1 0 - crisfsbufr cris-fsr npp cris-fsr_npp 0.0 1 0 - seviribufr seviri m08 seviri_m08 0.0 1 0 - seviribufr seviri m09 seviri_m09 0.0 1 0 - seviribufr seviri m10 seviri_m10 0.0 1 0 - seviribufr seviri m11 seviri_m11 0.0 1 0 - gsnd1bufr sndrd1 g15 sndrD1_g15 0.0 1 0 - gsnd1bufr sndrd2 g15 sndrD2_g15 0.0 1 0 - gsnd1bufr sndrd3 g15 sndrD3_g15 0.0 1 0 - gsnd1bufr sndrd4 g15 sndrD4_g15 0.0 1 0 - prepbufr mta_cld null mta_cld 1.0 0 0 - prepbufr gos_ctp null gos_ctp 1.0 0 0 - lgycldbufr larccld null larccld 1.0 0 0 -:: - &SUPEROB_RADAR - del_azimuth=5.,del_elev=.25,del_range=5000.,del_time=.5,elev_angle_max=5.,minnum=50,range_max=100000., - l2superob_only=.false., - / - &LAG_DATA - / - &HYBRID_ENSEMBLE - / - &RAPIDREFRESH_CLDSURF - dfi_radar_latent_heat_time_period=30.0, - / - &CHEM - / - &SINGLEOB_TEST - / - &NST - / -" ;; *) diff --git a/regression/regression_param.sh b/regression/regression_param.sh index 6ee72f14da..bfc6f042fc 100755 --- a/regression/regression_param.sh +++ b/regression/regression_param.sh @@ -84,17 +84,17 @@ case $regtest in ;; - rrfs_3denvar_glbens) + rrfs_3denvar_rdasens) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" + topts[1]="0:05:00" ; popts[1]="40/3/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/5/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/2" + topts[1]="0:05:00" ; popts[1]="40/3/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/5/" ; ropts[2]="/2" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="5/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="10/4/" ; ropts[2]="/1" @@ -173,17 +173,17 @@ case $regtest in ;; - netcdf_fv3_regional) + rrfs_enkf_conv) if [[ "$machine" = "Hera" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:05:00" ; popts[1]="40/2/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/4/" ; ropts[2]="/1" elif [[ "$machine" = "Orion" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" elif [[ "$machine" = "Hercules" ]]; then - topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" + topts[1]="0:05:00" ; popts[1]="40/2/" ; ropts[1]="/1" + topts[2]="0:05:00" ; popts[2]="40/4/" ; ropts[2]="/1" elif [[ "$machine" = "Jet" ]]; then topts[1]="0:15:00" ; popts[1]="4/4/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="6/6/" ; ropts[2]="/1" @@ -191,8 +191,8 @@ case $regtest in topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" elif [[ "$machine" = "wcoss2" ]]; then - topts[1]="0:15:00" ; popts[1]="28/1/" ; ropts[1]="/1" - topts[2]="0:15:00" ; popts[2]="28/2/" ; ropts[2]="/1" + topts[1]="0:15:00" ; popts[1]="64/1/" ; ropts[1]="/1" + topts[2]="0:15:00" ; popts[2]="64/2/" ; ropts[2]="/1" fi if [ "$debug" = ".true." ] ; then diff --git a/regression/regression_test_enkf.sh b/regression/regression_test_enkf.sh index 38ee20ce99..ac839631c2 100755 --- a/regression/regression_test_enkf.sh +++ b/regression/regression_test_enkf.sh @@ -35,16 +35,30 @@ maxtime=1200 # Copy stdout and incr files # from $savdir to $tmpdir list="$exp1 $exp2 $exp3" -for exp in $list; do - $ncp $savdir/$exp/stdout ./stdout.$exp - nmem=10 - imem=1 - while [[ $imem -le $nmem ]]; do - member="_mem"`printf %03i $imem` - $ncp $savdir/$exp/incr_${global_adate}_fhr06$member $tmpdir/incr$member.$exp - (( imem = $imem + 1 )) +if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then + for exp in $list; do + $ncp $savdir/$exp/stdout ./stdout.$exp + nmem=5 + imem=1 + while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + $ncp $savdir/$exp/fv3sar_tile1_mem${member}_dynvars $tmpdir/dynvars$member.$exp + $ncp $savdir/$exp/fv3sar_tile1_mem${member}_tracer $tmpdir/tracer$member.$exp + (( imem = $imem + 1 )) + done done -done +else + for exp in $list; do + $ncp $savdir/$exp/stdout ./stdout.$exp + nmem=10 + imem=1 + while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + $ncp $savdir/$exp/incr_${global_adate}_fhr06$member $tmpdir/incr$member.$exp + (( imem = $imem + 1 )) + done + done +fi # Grep out ensemble mean increment information, run time, and maximum resident memory from stdout file list="$exp1 $exp2 $exp3" @@ -223,16 +237,36 @@ fi # Next, check reproducibility of results between exp1 and exp2 -if [[ `expr substr $exp1 1 4` = "rtma" ]]; then +if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then { -if cmp -s siganl.${exp1} siganl.${exp2} -then - echo 'The results between the two runs ('${exp1}' and '${exp2}') are reproducible' - echo 'since the corresponding results are identical.' - echo -fi +nmem=5 +imem=1 +while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + ncdump dynvars$member.${exp1} > dynvars$member.${exp1}.out + ncdump dynvars$member.${exp2} > dynvars$member.${exp2}.out + if [ ! diff dynvars$member.${exp1}.out dynvars$member.${exp2}.out ]; then + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp2}' are NOT identical' + failed_test=1 + else + rm -f dynvars$member.${exp1}.out dynvars$member.${exp2}.out + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp2}' are identical' + fi + ncdump tracer$member.${exp1} > tracers$member.${exp1}.out + ncdump tracer$member.${exp2} > tracers$member.${exp2}.out + if [ ! diff tracers$member.${exp1}.out tracers$member.${exp2}.out ]; then + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp2}' are NOT identical' + failed_test=1 + else + rm -f tracers$member.${exp1}.out tracers$member.${exp2}.out + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp2}' are identical' + q + fi + (( imem = $imem + 1 )) +done +echo } >> $output @@ -321,16 +355,35 @@ else # Next, check reproducibility of results between exp1 and exp3 - if [[ `expr substr $exp1 1 4` = "rtma" ]]; then + if [[ $(expr substr $exp1 1 4) = "rrfs" ]]; then { - if cmp -s wrf_inout.${exp1} wrf_inout.${exp3} - then - echo 'The results between the two runs ('${exp1}' and '${exp3}') are reproducible' - echo 'since the corresponding results are identical.' - echo - fi + nmem=5 + imem=1 + while [[ $imem -le $nmem ]]; do + member="_mem"`printf %03i $imem` + ncdump dynvars$member.${exp1} > dynvars$member.${exp1}.out + ncdump dynvars$member.${exp3} > dynvars$member.${exp3}.out + if [ ! diff dynvars$member.${exp1}.out dynvars$member.${exp3}.out ]; then + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp3}' are NOT identical' + failed_test=1 + else + rm -f dynvars$member.${exp1}.out dynvars$member.${exp3}.out + echo 'dynvars'$member'.'${exp1}' dynvars'$member'.'${exp3}' are identical' + fi + ncdump tracer$member.${exp1} > tracers$member.${exp1}.out + ncdump tracer$member.${exp3} > tracers$member.${exp3}.out + if [ ! diff tracers$member.${exp1}.out tracers$member.${exp3}.out ]; then + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp3}' are NOT identical' + failed_test=1 + else + rm -f tracers$member.${exp1}.out tracers$member.${exp3}.out + echo 'tracer'$member'.'${exp1}' tracer'$member'.'${exp3}' are identical' + fi + (( imem = $imem + 1 )) + done + echo } >> $output diff --git a/regression/regression_var.sh b/regression/regression_var.sh index aebbccab8b..3e5487009d 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -188,19 +188,19 @@ export JCAP="62" # Case Study analysis dates export global_adate="2024022300" export rtma_adate="2020022420" -export fv3_netcdf_adate="2017030100" -export rrfs_3denvar_glbens_adate="2021072518" +export rrfs_enkf_adate="2023061012" +export rrfs_3denvar_rdasens_adate="2023061012" export hafs_envar_adate="2020082512" # Paths for canned case data. export global_data="$casesdir/gfs/prod" export rtma_obs="$casesdir/regional/rtma_binary/$rtma_adate" export rtma_ges="$casesdir/regional/rtma_binary/$rtma_adate" -export fv3_netcdf_obs="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" -export fv3_netcdf_ges="$casesdir/regional/fv3_netcdf/$fv3_netcdf_adate" -export rrfs_3denvar_glbens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/obs" -export rrfs_3denvar_glbens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ges" -export rrfs_3denvar_glbens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_glbens_adate/ens" +export rrfs_enkf_diag="$casesdir/regional/rrfs/$rrfs_enkf_adate/diag" +export rrfs_enkf_ges="$casesdir/regional/rrfs/$rrfs_enkf_adate/ens" +export rrfs_3denvar_rdasens_obs="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/obs" +export rrfs_3denvar_rdasens_ges="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/ges" +export rrfs_3denvar_rdasens_ens="$casesdir/regional/rrfs/$rrfs_3denvar_rdasens_adate/ens" export hafs_envar_obs="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/obs" export hafs_envar_ges="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ges" export hafs_envar_ens="$casesdir/regional/hafs_RTdata/$hafs_envar_adate/ens" diff --git a/regression/rrfs_3denvar_glbens.sh b/regression/rrfs_3denvar_rdasens.sh similarity index 55% rename from regression/rrfs_3denvar_glbens.sh rename to regression/rrfs_3denvar_rdasens.sh index af5da51172..b00047ec65 100755 --- a/regression/rrfs_3denvar_glbens.sh +++ b/regression/rrfs_3denvar_rdasens.sh @@ -21,7 +21,7 @@ exp=$jobname # #----------------------------------------------------------------------- # -adate=${rrfs_3denvar_glbens_adate} +adate=${rrfs_3denvar_rdasens_adate} YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}") JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}") @@ -31,9 +31,6 @@ DD=${YYYYMMDDHH:6:2} HH=${YYYYMMDDHH:8:2} YYYYMMDD=${YYYYMMDDHH:0:8} # -#MESO_USELIST_FN=$(date +%Y-%m-%d -d "${START_DATE} -1 day")_meso_uselist.txt -#AIR_REJECT_FN=$(date +%Y%m%d -d "${START_DATE} -1 day")_rejects.txt - # #----------------------------------------------------------------------- # @@ -42,17 +39,16 @@ YYYYMMDD=${YYYYMMDDHH:0:8} # #----------------------------------------------------------------------- # Set runtime and save directories -tmpdir=$tmpdir/tmpreg_rrfs_3denvar_glbens/${exp} -savdir=$savdir/outreg_rrfs_3denvar_glbens/${exp} +tmpdir=$tmpdir/tmpreg_rrfs_3denvar_rdasens/${exp} +savdir=$savdir/outreg_rrfs_3denvar_rdasens/${exp} # Set up $tmpdir rm -rf $tmpdir mkdir -p $tmpdir -chgrp rstprod $tmpdir chmod 750 $tmpdir cd $tmpdir -bkpath=${rrfs_3denvar_glbens_ges} +bkpath=${rrfs_3denvar_rdasens_ges} # decide background type if [ -r "${bkpath}/fv3_coupler.res" ]; then BKTYPE=0 # warm start @@ -68,19 +64,59 @@ fixcrtm=${fixcrtm:-$CRTM_FIX} # #--------------------------------------------------------------------- # -echo "regional_ensemble_option is ",${regional_ensemble_option:-1} - +regional_ensemble_option=${regional_ensemble_option:-5} +NUM_ENS_MEMBERS=5 +echo "regional_ensemble_option is ",${regional_ensemble_option} +echo "regional_ensemble number is ",${NUM_ENS_MEMBERS} echo "$VERBOSE" "fixgsi is $fixgsi" -echo "$VERBOSE" "fixgriddir is $fixgriddir" echo "$VERBOSE" "default bkpath is $bkpath" echo "$VERBOSE" "background type is is $BKTYPE" ifhyb=.false. -if [[ ${regional_ensemble_option:-1} -eq 1 ]]; then #using GDAS +# +# Check if we have enough FV3-LAM ensembles when regional_ensemble_option=5 +# +if [[ ${regional_ensemble_option} -eq 5 ]]; then + + imem=1 + ifound=0 + while [[ $imem -le ${NUM_ENS_MEMBERS} ]];do + memcharv0=$( printf "%03d" $imem ) + memchar=mem$( printf "%04d" $imem ) + + restart_prefix="${YYYYMMDD}.${HH}0000." + slash_ensmem_subdir=$memchar + bkpathmem=${rrfs_3denvar_rdasens_ens}/${slash_ensmem_subdir}/fcst_fv3lam/RESTART + + dynvarfile=${bkpathmem}/${restart_prefix}fv_core.res.tile1.nc + tracerfile=${bkpathmem}/${restart_prefix}fv_tracer.res.tile1.nc + phyvarfile=${bkpathmem}/${restart_prefix}phy_data.nc + if [ -r "${dynvarfile}" ] && [ -r "${tracerfile}" ] && [ -r "${phyvarfile}" ] ; then + ln -snf ${bkpathmem}/${restart_prefix}fv_core.res.tile1.nc fv3SAR01_ens_mem${memcharv0}-fv3_dynvars + ln -snf ${bkpathmem}/${restart_prefix}fv_tracer.res.tile1.nc fv3SAR01_ens_mem${memcharv0}-fv3_tracer + ln -snf ${bkpathmem}/${restart_prefix}phy_data.nc fv3SAR01_ens_mem${memcharv0}-fv3_phyvars + (( ifound += 1 )) + else + print_info_msg "WARNING: Cannot find ensemble files: ${dynvarfile} ${tracerfile} ${phyvarfile} " + fi + (( imem += 1 )) + done + + ifhyb=.true. + nummem=${NUM_ENS_MEMBERS} + if [[ $ifound -ne ${NUM_ENS_MEMBERS} ]] || [[ ${BKTYPE} -eq 1 ]]; then + print_info_msg "Not enough FV3_LAM ensembles, will fall to GDAS" + regional_ensemble_option=1 + l_both_fv3sar_gfs_ens=.false. + ifhyb=.false. + fi +fi +# +if [[ ${regional_ensemble_option} -eq 1 ]]; then #using GDAS #----------------------------------------------------------------------- # Make a list of the latest GFS EnKF ensemble #----------------------------------------------------------------------- - ls ${rrfs_3denvar_glbens_ens}/*gdas.t??z.atmf009.mem0??.nc >> filelist03 + ls ${rrfs_3denvar_rdasens_ens}/*gdas.t??z.atmf009.mem0??.nc >> filelist03 nummem=$(more filelist03 | wc -l) nummem=$((nummem - 3 )) @@ -109,12 +145,13 @@ ln -snf ${bkpath}/fv3_akbk fv3_akbk ln -snf ${bkpath}/fv3_grid_spec fv3_grid_spec if [ ${BKTYPE} -eq 1 ]; then # cold start uses background from INPUT - ln -snf ${bkpath}/phis.nc phis.nc - ncks -A -v phis phis.nc ${bkpath}/gfs_data.tile7.halo0.nc - ln_vrfy -snf ${bkpath}/sfc_data.tile7.halo0.nc fv3_sfcdata - ln_vrfy -snf ${bkpath}/gfs_data.tile7.halo0.nc fv3_dynvars - ln_vrfy -s fv3_dynvars fv3_tracer + cp ${bkpath}/sfc_data.tile7.halo0.nc fv3_sfcdata + cp ${bkpath}/gfs_data.tile7.halo0.nc fv3_dynvars + ln_vrfy -s fv3_dynvars fv3_tracer + + ln -snf ${bkpath}/phis.nc phis.nc + ncks -A -v phis phis.nc fv3_dynvars fv3lam_bg_type=1 else # cycle uses background from restart @@ -133,7 +170,6 @@ sed -i "s/mm/${MM}/" coupler.res sed -i "s/dd/${DD}/" coupler.res sed -i "s/hh/${HH}/" coupler.res - # #----------------------------------------------------------------------- # @@ -143,7 +179,7 @@ sed -i "s/hh/${HH}/" coupler.res #----------------------------------------------------------------------- obs_source=rap obsfileprefix=${YYYYMMDDHH}.${obs_source} - obspath_tmp=${rrfs_3denvar_glbens_obs} + obspath_tmp=${rrfs_3denvar_rdasens_obs} obs_files_source[0]=${obspath_tmp}/${obsfileprefix}.t${HH}${SUBH}z.prepbufr.tm00 obs_files_target[0]=prepbufr @@ -156,6 +192,73 @@ sed -i "s/hh/${HH}/" coupler.res obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}${SUBH}z.nexrad.tm00.bufr_d obs_files_target[${obs_number}]=l2rwbufr + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${YYYYMMDDHH}.Gridded_ref.nc + obs_files_target[${obs_number}]=dbzobs.nc + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${YYYYMMDDHH}.fedobs.nc + obs_files_target[${obs_number}]=fedobs.nc + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.1bamua.tm00.bufr_d + obs_files_target[${obs_number}]=amsuabufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esamua.tm00.bufr_d + obs_files_target[${obs_number}]=amsuabufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.1bmhs.tm00.bufr_d + obs_files_target[${obs_number}]=mhsbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esmhs.tm00.bufr_d + obs_files_target[${obs_number}]=mhsbufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.atms.tm00.bufr_d + obs_files_target[${obs_number}]=atmsbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esatms.tm00.bufr_d + obs_files_target[${obs_number}]=atmsbufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.atmsdb.tm00.bufr_d + obs_files_target[${obs_number}]=atmsbufr_db + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.crisf4.tm00.bufr_d + obs_files_target[${obs_number}]=crisfsbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.crsfdb.tm00.bufr_d + obs_files_target[${obs_number}]=crisfsbufr_db + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.mtiasi.tm00.bufr_d + obs_files_target[${obs_number}]=iasibufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.esiasi.tm00.bufr_d + obs_files_target[${obs_number}]=iasibufrears + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.iasidb.tm00.bufr_d + obs_files_target[${obs_number}]=iasibufr_db + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.gsrcsr.tm00.bufr_d + obs_files_target[${obs_number}]=abibufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.ssmisu.tm00.bufr_d + obs_files_target[${obs_number}]=ssmisbufr + + obs_number=${#obs_files_source[@]} + obs_files_source[${obs_number}]=${obspath_tmp}/${obsfileprefix}.t${HH}z.sevcsr.tm00.bufr_d + obs_files_target[${obs_number}]=sevcsr obs_number=${#obs_files_source[@]} for (( i=0; i<${obs_number}; i++ )); @@ -176,7 +279,7 @@ done # #----------------------------------------------------------------------- -ANAVINFO=${fixgsi}/anavinfo.rrfs +ANAVINFO=${fixgsi}/anavinfo.rrfs_conv_dbz CONVINFO=${fixgsi}/convinfo.rrfs HYBENSINFO=${fixgsi}/hybens_info.rrfs OBERROR=${fixgsi}/errtable.rrfs @@ -198,9 +301,31 @@ cp $OBERROR errtable cp $ATMS_BEAMWIDTH atms_beamwidth.txt cp ${HYBENSINFO} hybens_info -cp ${bkpath}/gsd_sfcobs_provider.txt gsd_sfcobs_provider.txt -cp ${bkpath}/current_bad_aircraft current_bad_aircraft -cp ${bpath}/gsd_sfcobs_uselist.txt gsd_sfcobs_uselist.txt +cp ${obspath_tmp}/gsd_sfcobs_provider.txt gsd_sfcobs_provider.txt +cp ${obspath_tmp}/current_bad_aircraft current_bad_aircraft +cp ${obspath_tmp}/gsd_sfcobs_uselist.txt gsd_sfcobs_uselist.txt + +#----------------------------------------------------------------------- +# +# cycling radiance bias corretion files +# +#----------------------------------------------------------------------- + +cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_satbias_pc ./satbias_pc +cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_satbias ./satbias_in +cp $obspath_tmp/rrfs.prod.${YYYYMMDDHH}_radstat ./radstat.rrfs + +if [ -r radstat.rrfs ]; then + listdiag=$(tar xvf radstat.rrfs | cut -d' ' -f2 | grep _ges) + for type in $listdiag; do + diag_file=$(echo $type | cut -d',' -f1) + fname=$(echo $diag_file | cut -d'.' -f1) + date=$(echo $diag_file | cut -d'.' -f2) + gunzip $diag_file + fnameanl=$(echo $fname|sed 's/_ges//g') + mv $fname.$date* $fnameanl + done +fi #----------------------------------------------------------------------- # @@ -261,9 +386,9 @@ HYBRID_ENSEMBLE='ensemble_path="",' SINGLEOB="$SINGLEOB_update" if [ "$debug" = ".false." ]; then - . $scripts/regression_namelists.sh rrfs_3denvar_glbens + . $scripts/regression_namelists.sh rrfs_3denvar_rdasens else - . $scripts/regression_namelists_db.sh rrfs_3denvar_glbens + . $scripts/regression_namelists_db.sh rrfs_3denvar_rdasens fi cat << EOF > gsiparm.anl @@ -279,10 +404,6 @@ elif [[ $exp == *"contrl"* ]]; then $ncp $gsiexec_contrl ./gsi.x fi -#cp $fv3_netcdf_ges/nam.t06z.satbias_pc.tm04 ./satbias_pc -#cp $fv3_netcdf_ges/nam.t06z.satbias.tm04 ./satbias_in -#cp $fv3_netcdf_ges/nam.t06z.radstat.tm04 ./radstat.gdas - # Run GSI cd $tmpdir echo "run gsi now" diff --git a/regression/rrfs_enkf_conv.sh b/regression/rrfs_enkf_conv.sh new file mode 100755 index 0000000000..21f7aacee2 --- /dev/null +++ b/regression/rrfs_enkf_conv.sh @@ -0,0 +1,223 @@ + +set -x + +# Set variables used in script +# CLEAN up $tmpdir when finished (YES=remove, NO=leave alone) +# ncp is cp replacement, currently keep as /bin/cp + +UNCOMPRESS=gunzip +CLEAN=NO +ncp=/bin/cp +# +# Set experiment name +# +exp=$jobname + +#----------------------------------------------------------------------- +# +# Extract from ADATE the starting year, month, day, and hour of the +# forecast. These are needed below for various operations. +# +#----------------------------------------------------------------------- +# + +adate=${rrfs_enkf_adate} +YYYYMMDDHH=$(date +%Y%m%d%H -d "${adate:0:8} ${adate:8:2}") +JJJ=$(date +%j -d "${adate:0:8} ${adate:8:2}") + +YYYY=${YYYYMMDDHH:0:4} +MM=${YYYYMMDDHH:4:2} +DD=${YYYYMMDDHH:6:2} +HH=${YYYYMMDDHH:8:2} +YYYYMMDD=${YYYYMMDDHH:0:8} + +# +#----------------------------------------------------------------------- +# +# go to working directory and save directory. +# define fix and background path +# +#----------------------------------------------------------------------- +# Set runtime and save directories +tmpdir=$tmpdir/tmpreg_rrfs_enkf_conv/${exp} +savdir=$savdir/outreg_rrfs_enkf_conv/${exp} + +# Set up $tmpdir +rm -rf $tmpdir +mkdir -p $tmpdir +chmod 750 $tmpdir +cd $tmpdir + +fixcrtm=${fixcrtm:-$CRTM_FIX} + +cp ${rrfs_3denvar_rdasens_ges}/fv3_coupler.res coupler.res +cp ${rrfs_3denvar_rdasens_ges}/fv3_akbk fv3sar_tile1_akbk.nc +cp ${rrfs_3denvar_rdasens_ges}/fv3_grid_spec fv3sar_tile1_grid_spec.nc + +# +#----------------------------------------------------------------------- +# +# Loop through the members, link the background and copy over +# observer output (diag*ges*) files to the running directory +# +#----------------------------------------------------------------------- +# +ob_type="conv" +DO_ENS_RADDA="false" +nens=${nens:-5} +netcdf_diag=".true." +for imem in $(seq 1 $nens) ensmean; do + + if [ "${imem}" = "ensmean" ]; then + memchar="ensmean" + memcharv0="ensmean" + restart_prefix="" + else + memchar="mem"$(printf %04i $imem) + memcharv0="mem"$(printf %03i $imem) + restart_prefix="${YYYYMMDD}.${HH}0000." + fi + slash_ensmem_subdir=$memchar + bkpath=${rrfs_enkf_ges}/${slash_ensmem_subdir}/fcst_fv3lam/RESTART + observer_nwges_dir="${rrfs_enkf_diag}/${slash_ensmem_subdir}/observer_gsi" + + cp ${bkpath}/${restart_prefix}fv_core.res.tile1.nc fv3sar_tile1_${memcharv0}_dynvars + cp ${bkpath}/${restart_prefix}fv_tracer.res.tile1.nc fv3sar_tile1_${memcharv0}_tracer + cp ${bkpath}/${restart_prefix}sfc_data.nc fv3sar_tile1_${memcharv0}_sfcdata + cp ${bkpath}/${restart_prefix}phy_data.nc fv3sar_tile1_${memcharv0}_phyvar + + # +#----------------------------------------------------------------------- +# +# Copy observer outputs (diag*ges*) to the working directory +# +#----------------------------------------------------------------------- +# + if [ "${netcdf_diag}" = ".true." ] ; then + # Note, listall_rad is copied from exrrfs_run_analysis.sh + listall_rad="hirs2_n14 msu_n14 sndr_g08 sndr_g11 sndr_g11 sndr_g12 sndr_g13 sndr_g08_prep sndr_g11_prep sndr_g12_prep sndr_g13_prep sndrd1_g11 sndrd2_g11 sndrd3_g11 sndrd4_g11 sndrd1_g15 sndrd2_g15 sndrd3_g15 sndrd4_g15 sndrd1_g13 sndrd2_g13 sndrd3_g13 sndrd4_g13 hirs3_n15 hirs3_n16 hirs3_n17 amsua_n15 amsua_n16 amsua_n17 amsua_n18 amsua_n19 amsua_metop-a amsua_metop-b amsua_metop-c amsub_n15 amsub_n16 amsub_n17 hsb_aqua airs_aqua amsua_aqua imgr_g08 imgr_g11 imgr_g12 pcp_ssmi_dmsp pcp_tmi_trmm conv sbuv2_n16 sbuv2_n17 sbuv2_n18 omi_aura ssmi_f13 ssmi_f14 ssmi_f15 hirs4_n18 hirs4_metop-a mhs_n18 mhs_n19 mhs_metop-a mhs_metop-b mhs_metop-c amsre_low_aqua amsre_mid_aqua amsre_hig_aqua ssmis_las_f16 ssmis_uas_f16 ssmis_img_f16 ssmis_env_f16 iasi_metop-a iasi_metop-b iasi_metop-c seviri_m08 seviri_m09 seviri_m10 seviri_m11 cris_npp atms_npp ssmis_f17 cris-fsr_npp cris-fsr_n20 atms_n20 abi_g16" + + + if [ "${ob_type}" = "conv" ]; then + list_ob_type="conv_ps conv_q conv_t conv_uv conv_pw conv_rw conv_sst" + + if [ "${DO_ENS_RADDA}" = "TRUE" ]; then + list_ob_type="$list_ob_type $listall_rad" + fi + fi + + if [ "${ob_type}" = "radardbz" ]; then + if [ ${DO_GLM_FED_DA} == "TRUE" ]; then + list_ob_type="conv_dbz conv_fed" + else + list_ob_type="conv_dbz" + fi + fi + for sub_ob_type in ${list_ob_type} ; do + diagfile0=${observer_nwges_dir}/diag_${sub_ob_type}_ges.${YYYYMMDDHH}.nc4.gz + if [ -s $diagfile0 ]; then + diagfile=$(basename $diagfile0) + cp $diagfile0 $diagfile + gzip -d $diagfile && rm -f $diagfile + ncfile0=$(basename -s .gz $diagfile) + ncfile=$(basename -s .nc4 $ncfile0) + mv $ncfile0 ${ncfile}_${memcharv0}.nc4 + fi + done + else + for diagfile0 in $(ls ${observer_nwges_dir}/diag*${ob_type}*ges* ) ; do + if [ -s $diagfile0 ]; then + diagfile=$(basename $diagfile0) + cp $diagfile0 diag_conv_ges.$memcharv0 + fi + done + fi +done + +# +#----------------------------------------------------------------------- +# +# Set GSI fix files +# +#---------------------------------------------------------------------- +# +found_ob_type=0 + +CONVINFO=${fixgsi}/convinfo.rrfs + +if [ "${ob_type}" = "conv" ]; then + ANAVINFO=${fixgsi}/anavinfo.rrfs + found_ob_type=1 +fi +if [ "${ob_type}" = "radardbz" ]; then + ANAVINFO=${fixgsi}/anavinfo.enkf.rrfs_dbz + CORRLENGTH="18" + LNSIGCUTOFF="0.5" + found_ob_type=1 +fi +if [ ${found_ob_type} == 0 ]; then + err_exit "Unknown observation type: ${ob_type}" +fi +stdout_name=stdout.${ob_type} +stderr_name=stderr.${ob_type} + +SATINFO=${fixgsi}/global_satinfo.txt +OZINFO=${fixgsi}/global_ozinfo.txt + +cp ${ANAVINFO} anavinfo +cp $SATINFO satinfo +cp $CONVINFO convinfo +cp $OZINFO ozinfo + +# +#----------------------------------------------------------------------- +# +# Get nlons (NX_RES), nlats (NY_RES) and nlevs +# +#----------------------------------------------------------------------- +# +NX_RES=$(ncdump -h fv3sar_tile1_grid_spec.nc | grep "grid_xt =" | cut -f3 -d" " ) +NY_RES=$(ncdump -h fv3sar_tile1_grid_spec.nc | grep "grid_yt =" | cut -f3 -d" " ) +nlevs=$(ncdump -h fv3sar_tile1_mem001_tracer | grep "zaxis_1 =" | cut -f3 -d" " ) +# +#---------------------------------------------------------------------- +# +# Set namelist parameters for EnKF +# +#---------------------------------------------------------------------- +# +EnKFTracerVars=${EnKFTracerVar:-"sphum,o3mr"} +ldo_enscalc_option=${ldo_enscalc_option:-0} + +# Make gsi namelist + +. $scripts/regression_namelists.sh rrfs_enkf_conv + +# + +cat << EOF > enkf.nml + +$gsi_namelist + +EOF + +# +#----------------------------------------------------------------------- +# +# Run the EnKF +# +#----------------------------------------------------------------------- +# +# Copy executable and fixed files to $tmpdir +if [[ $exp == *"updat"* ]]; then + $ncp $enkfexec_updat ./enkf.x +elif [[ $exp == *"contrl"* ]]; then + $ncp $enkfexec_contrl ./enkf.x +fi + +# Run enkf +cd $tmpdir +echo "run rrfs enkf now" +eval "$APRUN $tmpdir/enkf.x < enkf.nml > stdout 2>&1" +rc=$? +exit $rc From b37b7d73270bed86a1c80fd2013982948ece4955 Mon Sep 17 00:00:00 2001 From: David Huber <69919478+DavidHuber-NOAA@users.noreply.github.com> Date: Thu, 27 Jun 2024 08:59:16 -0400 Subject: [PATCH 34/35] Update Jet directories (#763) --- regression/regression_var.sh | 10 +++++----- ush/detect_machine.sh | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 3e5487009d..401c7e0022 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -32,7 +32,7 @@ fi # Determine the machine if [[ -d /scratch1 ]]; then # Hera export machine="Hera" -elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs1 ]]; then # Jet +elif [[ -d /mnt/lfs4 || -d /jetmon || -d /mnt/lfs5 ]]; then # Jet export machine="Jet" elif [[ -d /discover ]]; then # NCCS Discover export machine="Discover" @@ -137,16 +137,16 @@ case $machine in ;; Jet) - export noscrub=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/noscrub - export ptmp=/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/ptmp - export casesdir="/lfs1/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest" + export noscrub=/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/noscrub + export ptmp=/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/ptmp + export casesdir="/lfs5/NESDIS/nesdis-rdo2/David.Huber/save/CASES/regtest" export check_resource="no" export accnt="nesdis-rdo2" export group="global" export queue="batch" if [[ "$cmaketest" = "false" ]]; then - export basedir="/lfs1/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi" + export basedir="/lfs5/NESDIS/nesdis-rdo2/$LOGNAME/save/git/gsi" fi # On Jet, there are no scrubbers to remove old contents from stmp* directories. diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index 683ee0db7f..6562b183b6 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -67,7 +67,7 @@ if [[ -d /lfs/h3 ]]; then elif [[ -d /lfs/h1 && ! -d /lfs/h3 ]]; then # We are on NOAA TDS Acorn MACHINE_ID=acorn -elif [[ -d /mnt/lfs1 ]]; then +elif [[ -d /mnt/lfs5 ]]; then # We are on NOAA Jet MACHINE_ID=jet elif [[ -d /scratch1 ]]; then From 529bb796bea0e490f186729cd168a91c034bb12d Mon Sep 17 00:00:00 2001 From: RussTreadon-NOAA <26926959+RussTreadon-NOAA@users.noreply.github.com> Date: Fri, 28 Jun 2024 16:10:41 -0400 Subject: [PATCH 35/35] Updates to build and run on Orion Rocky 9 (#764) note; while this commit enables gsi.x and enkf.x to be built on Orion Rocky 9, both executables run 2x slower on Orion Rocky 9 than Orion Centos 7 --- modulefiles/gsi_orion.intel.lua | 9 +++++---- regression/regression_var.sh | 11 +++++++---- ush/detect_machine.sh | 4 ++-- ush/sub_orion | 8 +++++--- 4 files changed, 19 insertions(+), 13 deletions(-) diff --git a/modulefiles/gsi_orion.intel.lua b/modulefiles/gsi_orion.intel.lua index 03ea22018d..d05bda5b2e 100644 --- a/modulefiles/gsi_orion.intel.lua +++ b/modulefiles/gsi_orion.intel.lua @@ -1,11 +1,11 @@ help([[ ]]) -prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env/install/modulefiles/Core") +prepend_path("MODULEPATH", "/work/noaa/epic/role-epic/spack-stack/orion/spack-stack-1.6.0/envs/gsi-addon-env-rocky9/install/modulefiles/Core") -local stack_python_ver=os.getenv("python_ver") or "3.11.6" -local stack_intel_ver=os.getenv("stack_intel_ver") or "2022.0.2" -local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.5.1" +local stack_python_ver=os.getenv("stack_python_ver") or "3.11.6" +local stack_intel_ver=os.getenv("stack_intel_ver") or "2021.9.0" +local stack_impi_ver=os.getenv("stack_impi_ver") or "2021.9.0" local cmake_ver=os.getenv("cmake_ver") or "3.23.1" local prod_util_ver=os.getenv("prod_util_ver") or "2.1.1" @@ -16,6 +16,7 @@ load(pathJoin("cmake", cmake_ver)) load("gsi_common") load(pathJoin("prod_util", prod_util_ver)) +load("intel-oneapi-mkl/2022.2.1") pushenv("CFLAGS", "-xHOST") pushenv("FFLAGS", "-xHOST") diff --git a/regression/regression_var.sh b/regression/regression_var.sh index 401c7e0022..4a2bc85874 100755 --- a/regression/regression_var.sh +++ b/regression/regression_var.sh @@ -40,10 +40,13 @@ elif [[ -d /ncrc ]]; then # Gaea export machine="Gaea" elif [[ -d /data/prod ]]; then # S4 export machine="S4" -elif [[ -d /work && $(hostname) =~ "Orion" ]]; then # Orion - export machine="Orion" -elif [[ -d /work && $(hostname) =~ "hercules" ]]; then # Hercules - export machine="Hercules" +elif [[ -d /work ]]; then # Orion or Hercules + mount=$(findmnt -n -o SOURCE /home) + if [[ ${mount} =~ "hercules" ]]; then + export machine="Hercules" + else + export machine="Orion" + fi elif [[ -d /lfs/h2 ]]; then # wcoss2 export machine="wcoss2" fi diff --git a/ush/detect_machine.sh b/ush/detect_machine.sh index 6562b183b6..0beb937f7e 100755 --- a/ush/detect_machine.sh +++ b/ush/detect_machine.sh @@ -75,8 +75,8 @@ elif [[ -d /scratch1 ]]; then MACHINE_ID=hera elif [[ -d /work ]]; then # We are on MSU Orion or Hercules - if [[ -d /apps/other ]]; then - # We are on Hercules + mount=$(findmnt -n -o SOURCE /home) + if [[ ${mount} =~ "hercules" ]]; then MACHINE_ID=hercules else MACHINE_ID=orion diff --git a/ush/sub_orion b/ush/sub_orion index b810576379..371c30e321 100755 --- a/ush/sub_orion +++ b/ush/sub_orion @@ -115,23 +115,25 @@ echo "#SBATCH --nodes=$nodes --ntasks-per-node=$procs --exclusive" >> $cfile echo "#SBATCH --account=$accnt" >> $cfile echo "" >>$cfile +echo "set -x" >> $cfile echo "export ntasks=$(( $nodes * $procs ))" >> $cfile echo "export ppn=$procs" >> $cfile echo "export threads=$threads" >> $cfile echo "export OMP_NUM_THREADS=$threads" >> $cfile -##echo "export OMP_STACKSIZE=2048M" >> $cfile echo "ulimit -s unlimited" >> $cfile echo "" >>$cfile echo ". "$(awk '{ print $1, $2, $3, $4, $5, $6, $7, $8, $9 }' $regdir/regression_var.out) >>$cfile echo "" >>$cfile -echo ". /apps/lmod/lmod/init/sh" >> $cfile +echo ". /apps/other/lmod/lmod/init/sh" >> $cfile echo "module purge" >> $cfile echo "module use $modulefiles" >> $cfile echo "module load gsi_orion.intel" >> $cfile echo "module list" >> $cfile -echo "" >> $cfile +#TODO reenable I_MPI_EXTRA_FILESYSTEM once regional ctests can properly handle parallel I/O on Orion +echo "unset I_MPI_EXTRA_FILESYSTEM" >> $cfile + cat $exec >> $cfile if [[ $nosub = YES ]];then