From 982dc34fa568a5637d2ef83e749798b29cfe746f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 10 Jul 2023 14:28:35 -0400 Subject: [PATCH 001/141] Backport bugfixes to 2.35 This release backports fixes for ExtData2G handling of climatologies in weird circumstances and a fix for HISTORY handling of 1-bin output from GOCART. --- CHANGELOG.md | 7 +++++++ CMakeLists.txt | 2 +- base/Base/Base_Base_implementation.F90 | 1 - gridcomps/ExtData2G/ExtDataClimFileHandler.F90 | 17 +++++++++-------- 4 files changed, 17 insertions(+), 10 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8a5158286872..3ed000a48219 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,13 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated +## [2.35.4] - 2023-07-11 + +### Fixed + +- Added bug fix when using climatology option in ExtData2G under certain scenarios (see [#2192](https://github.com/GEOS-ESM/MAPL/issues/2192) for more information) +- Fixed logic in generating the names of the split fields. If the alias field in the History.rc has separators (;), each substring is used to name the resulting fields. If there are no separators, this will be the exact name of the first split field + ## [2.35.3] - 2023-03-17 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 436b84ff8161..e9bf42ba68de 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -4,7 +4,7 @@ cmake_policy (SET CMP0054 NEW) project ( MAPL - VERSION 2.35.3 + VERSION 2.35.4 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the default build type to release diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index ba3da7a2f233..c4225c9e3e8b 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -3924,7 +3924,6 @@ subroutine genAlias(name, n, splitNameArray, aliasName, rc) deallocate(tmp) ! if the user did no supply enough separated alias field names, ! append 00i to the original field name - if (n==1) nn=0 do i=nn+1,n write(splitNameArray(i),'(A,I3.3)') trim(name), i end do diff --git a/gridcomps/ExtData2G/ExtDataClimFileHandler.F90 b/gridcomps/ExtData2G/ExtDataClimFileHandler.F90 index d6121adade33..8b012d3e5e4f 100644 --- a/gridcomps/ExtData2G/ExtDataClimFileHandler.F90 +++ b/gridcomps/ExtData2G/ExtDataClimFileHandler.F90 @@ -13,6 +13,7 @@ module MAPL_ExtdataClimFileHandler use MAPL_StringTemplate use MAPL_ExtDataBracket use MAPL_ExtDataConstants + use MAPL_CommsMod implicit none private public ExtDataClimFileHandler @@ -59,10 +60,10 @@ subroutine get_file_bracket(this, input_time, source_time, bracket, fail_on_miss allocate(source_years(2)) call ESMF_TimeGet(source_time(1),yy=source_years(1),_RC) call ESMF_TimeGet(source_time(2),yy=source_years(2),_RC) - _ASSERT(source_years(1) >= valid_years(1),'source time outide valid range') - _ASSERT(source_years(1) <= valid_years(2),'source time outide valid range') - _ASSERT(source_years(2) >= valid_years(1),'source time outide valid range') - _ASSERT(source_years(2) <= valid_years(2),'source time outide valid range') + _ASSERT(source_time(1) >= this%valid_range(1),'source time outside valid range') + _ASSERT(source_time(1) <= this%valid_range(2),'source time outside valid range') + _ASSERT(source_time(2) >= this%valid_range(1),'source time outside valid range') + _ASSERT(source_time(2) <= this%valid_range(2),'source time outside valid range') end if ! shift target year to request source time if specified @@ -72,20 +73,20 @@ subroutine get_file_bracket(this, input_time, source_time, bracket, fail_on_miss !if (size(source_years)>0) then if (allocated(source_years)) then - if (target_year < source_years(1)) then + if (input_time < source_time(1)) then target_year = source_years(1) this%clim_year = target_year - else if (target_year >= source_years(2)) then + else if (input_time >= source_time(2)) then target_year = source_years(2) this%clim_year = target_year end if call swap_year(target_time,target_year,_RC) else - if (target_year < valid_years(1)) then + if (input_time <= this%valid_range(1)) then target_year = valid_years(1) this%clim_year = target_year call swap_year(target_time,target_year,_RC) - else if (target_year >= valid_years(2)) then + else if (input_time >= this%valid_range(2)) then target_year = valid_years(2) this%clim_year = target_year call swap_year(target_time,target_year,_RC) From 2e8314c8d24eeb94418e80d9951b4224c10d780e Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Sep 2023 15:42:43 -0400 Subject: [PATCH 002/141] changes for per writer output --- base/FileIOShared.F90 | 90 ++++++++- base/MaplGrid.F90 | 4 +- base/NCIO.F90 | 133 ++++++------ generic/MAPL_Generic.F90 | 424 ++++++++++++++------------------------- 4 files changed, 316 insertions(+), 335 deletions(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 67f63078799c..533c24e20db1 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -41,6 +41,8 @@ module FileIOSharedMod public dealloc_ public ArrDescrSet public ArrDescrInit + public ArrDescrCreateReaderComm + public ArrDescrCreateWriterComm ! Global vars: ! ------------ @@ -89,11 +91,9 @@ module FileIOSharedMod integer :: Xcomm, Ycomm, NX0, NY0 integer :: readers_comm, IOscattercomm integer :: writers_comm, IOgathercomm - integer :: face_writers_comm - integer :: face_readers_comm - integer :: face_index - logical :: write_restart_by_face = .false. - logical :: read_restart_by_face = .false. + integer :: myrow + logical :: split_restart = .false. + logical :: split_checkpoint = .false. integer, pointer :: i1(:), in(:), j1(:), jn(:) integer :: im_world, jm_world, lm_world type (ESMF_Grid) :: grid @@ -556,6 +556,8 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers ArrDes%iogathercomm = iogathercomm ArrDes%xcomm = xcomm ArrDes%ycomm = ycomm + call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,status) + _VERIFY(status) allocate(arrdes%i1(size(i1)),stat=status) _VERIFY(STATUS) @@ -579,10 +581,6 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers ArrDes%cb_buffer_size = "16777216" ArrDes%romio_cb_write = "enable" - ArrDes%face_readers_comm = MPI_COMM_NULL - ArrDes%face_writers_comm = MPI_COMM_NULL - ArrDes%face_index = 0 - ArrDes%tile = .false. ArrDes%filename = '' @@ -619,4 +617,78 @@ subroutine ArrDescrSet(ArrDes, offset, & end subroutine ArrDescrSet + subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) + type(ArrDescr), intent(inout) :: arrdes + integer, intent(in) :: full_comm + integer, intent(in) :: num_writers + integer, optional, intent(out) :: rc + + integer :: status, nx, ny, color, ny_by_writers, myid, j + + nx = size(arrdes%i1) + ny = size(arrdes%j1) + _ASSERT(num_writers < ny,'num writers must be less than NY') + _ASSERT(mod(ny,num_writers)==0,'num writerss must evenly divide NY') + call mpi_comm_rank(full_comm,myid, status) + _VERIFY(status) + color = arrdes%NX0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, status) + color = arrdes%NY0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, status) + ny_by_writers = ny/num_writers + if (mod(myid,nx*ny/num_writers) == 0) then + color = 0 + else + color = MPI_UNDEFINED + endif + call MPI_COMM_SPLIT(full_comm, color, myid, arrdes%writers_comm, status) + if (num_writers==ny) then + arrdes%IOgathercomm = arrdes%Xcomm + else + j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_writers) + call MPI_COMM_SPLIT(full_comm, j, myid, arrdes%IOgathercomm, status) + endif + + + _RETURN(_SUCCESS) + + end subroutine ArrDescrCreateWriterComm + + subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) + type(ArrDescr), intent(inout) :: arrdes + integer, intent(in) :: full_comm + integer, intent(in) :: num_readers + integer, optional, intent(out) :: rc + + integer :: status, nx, ny, color, ny_by_readers, myid, j + + nx = size(arrdes%i1) + ny = size(arrdes%j1) + _ASSERT(num_readers < ny,'num readers must be less than NY') + _ASSERT(mod(ny,num_readers)==0,'num readers must evenly divide NY') + + call mpi_comm_rank(full_comm,myid, status) + _VERIFY(status) + color = arrdes%NX0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, status) + color = arrdes%NY0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, status) + ny_by_readers = ny/num_readers + if (mod(myid,nx*ny/num_readers) == 0) then + color = 0 + else + color = MPI_UNDEFINED + endif + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%readers_comm, status) + if (num_readers==ny) then + arrdes%IOscattercomm = arrdes%Xcomm + else + j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_readers) + call MPI_COMM_SPLIT(full_comm, j, MYID, arrdes%IOscattercomm, status) + endif + + _RETURN(_SUCCESS) + + end subroutine ArrDescrCreateReaderComm + end module FileIOSharedMod diff --git a/base/MaplGrid.F90 b/base/MaplGrid.F90 index 0552df9ca01c..8bd648e2339e 100644 --- a/base/MaplGrid.F90 +++ b/base/MaplGrid.F90 @@ -30,9 +30,9 @@ module mapl_MaplGrid integer :: readers_comm, IOscattercomm integer :: writers_comm, IOgathercomm integer :: num_readers, num_writers - logical :: write_restart_by_face = .false. ! only apply to cubed-sphere grid + logical :: split_checkpoint = .false. ! only apply to cubed-sphere grid + logical :: split_restart = .false. ! only apply to cubed-sphere grid logical :: write_restart_by_oserver = .false. - logical :: read_restart_by_face = .false. ! only apply to cubed-sphere grid integer, allocatable :: i1(:), in(:), j1(:), jn(:) contains diff --git a/base/NCIO.F90 b/base/NCIO.F90 index dbcdee566033..1010f6ccd79f 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -31,7 +31,6 @@ module NCIOMod implicit none private - ! public routines public MAPL_IOChangeRes public MAPL_IOCountNonDimVars public MAPL_IOGetNonDimVars @@ -950,8 +949,8 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC cnt(3) = 1 cnt(4) = 1 - if(arrdes%write_restart_by_face) then - start(2) = start(2) - (arrdes%face_index-1)*IM_WORLD + if(arrdes%split_checkpoint) then + start(2) = 1 endif call formatter%put_var(trim(name),VAR,start=start,count=cnt,rc=status) @@ -1078,8 +1077,8 @@ subroutine MAPL_VarReadNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, RC) cnt(3) = 1 cnt(4) = 1 - if(arrdes%read_restart_by_face) then - start(2) = start(2) - (arrdes%face_index-1)*IM_WORLD + if(arrdes%split_checkpoint) then + start(2) = 1 endif call formatter%get_var(trim(name),VAR,start=start,count=cnt,rc=status) @@ -1422,13 +1421,8 @@ subroutine MAPL_VarWriteNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, of if (arrdes%writers_comm/=MPI_COMM_NULL) then - if (arrdes%write_restart_by_face) then - call MPI_COMM_RANK(arrdes%face_writers_comm, io_rank, STATUS) - _VERIFY(STATUS) - else - call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) - _VERIFY(STATUS) - endif + call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) + _VERIFY(STATUS) if (io_rank == 0) then call formatter%put_var(trim(name),A,start=start,count=cnt,rc=status) @@ -1728,13 +1722,8 @@ subroutine MAPL_VarWriteNCpar_R8_1d(formatter, name, A, layout, ARRDES, MASK, of if (arrdes%writers_comm/=MPI_COMM_NULL) then - if(arrdes%write_restart_by_face) then - call MPI_COMM_RANK(arrdes%face_writers_comm, io_rank, STATUS) - _VERIFY(STATUS) - else - call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) - _VERIFY(STATUS) - endif + call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) + _VERIFY(STATUS) if (io_rank == 0) then call formatter%put_var(trim(name),A,start=start,count=cnt,rc=status) @@ -2472,8 +2461,8 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, oC cnt(3) = 1 cnt(4) = 1 - if(arrdes%write_restart_by_face) then - start(2) = start(2) - (arrdes%face_index-1)*IM_WORLD + if(arrdes%split_checkpoint) then + start(2) = 1 endif call formatter%put_var(trim(name),VAR,start=start,count=cnt,rc=status) @@ -2599,8 +2588,8 @@ subroutine MAPL_VarReadNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, RC) cnt(3) = 1 cnt(4) = 1 - if(arrdes%read_restart_by_face) then - start(2) = start(2) - (arrdes%face_index-1)*IM_WORLD + if(arrdes%split_restart) then + start(2) = 1 endif call formatter%get_var(trim(name),VAR,start=start,count=cnt,rc=status) @@ -2691,11 +2680,11 @@ subroutine MAPL_BundleReadNCPar(Bundle, arrdes, filename, rc) integer :: ind type(ESMF_Grid) :: grid - integer :: MAPL_DIMS + integer :: MAPL_DIMS, reader_rank integer, pointer :: MASK(:) => null() type(Netcdf4_Fileformatter) :: formatter type(FileMetaData) :: metadata - character(len=:), allocatable :: fname_by_face + character(len=:), allocatable :: fname_by_rank logical :: grid_file_match,flip, restore_export, isPresent type(ESMF_VM) :: vm integer :: comm @@ -2715,9 +2704,12 @@ subroutine MAPL_BundleReadNCPar(Bundle, arrdes, filename, rc) call formatter%open(filename,pFIO_READ,rc=status) _VERIFY(STATUS) else - if(arrdes%read_restart_by_face .and. .not. arrdes%tile) then - fname_by_face = get_fname_by_face(trim(filename),arrdes%face_index) - call formatter%open(trim(fname_by_face),pFIO_READ,comm=arrdes%face_readers_comm,info=info,rc=status) + if(arrdes%split_restart .and. .not. arrdes%tile) then + + call MPI_COMM_RANK(arrdes%readers_comm,reader_rank,status) + _VERIFY(STATUS) + fname_by_rank = get_fname_by_face(trim(filename),reader_rank) + call formatter%open(trim(fname_by_rank),pFIO_READ,rc=status) _VERIFY(STATUS) else call formatter%open(filename,pFIO_READ,comm=arrdes%readers_comm,info=info,rc=status) @@ -2733,7 +2725,7 @@ subroutine MAPL_BundleReadNCPar(Bundle, arrdes, filename, rc) flip = check_flip(metadata,rc=status) _VERIFY(status) - _ASSERT(grid_file_match,"File grid dimensions in "//trim(filename)//" do not match grid") + !_ASSERT(grid_file_match,"File grid dimensions in "//trim(filename)//" do not match grid") endif call ESMF_VMGetCurrent(vm,rc=status) _VERIFY(status) @@ -2815,7 +2807,7 @@ function compare_grid_file(metadata,grid,rc) result(match) _VERIFY(status) file_lon_size = metadata%get_dimension("lon") file_lat_size = metadata%get_dimension("lat") - if (metadata%has_attribute("Cubed_Sphere_Face_Index")) file_lat_size = file_lat_size*6 + !if (metadata%has_attribute("Cubed_Sphere_Face_Index")) file_lat_size = file_lat_size*6 file_lev_size = metadata%get_dimension("lev") file_tile_size = metadata%get_dimension("tile") @@ -2879,7 +2871,7 @@ subroutine MAPL_StateVarReadNCPar(filename, STATE, arrdes, bootstrapable, NAME, _VERIFY(STATUS) if (MAPL_AM_I_Root()) then - if(arrdes%read_restart_by_face) then + if(arrdes%split_restart) then fname_by_face = get_fname_by_face(filename, 1) status = NF90_OPEN(trim(fname_by_face),NF90_NOWRITE, ncid) ! just pick one _VERIFY(STATUS) @@ -3309,8 +3301,8 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) type(FileMetadata) :: cf class (Variable), allocatable :: var class(*), allocatable :: coordinate_data(:) - integer :: pfDataType - character(len=:), allocatable :: fname_by_face + integer :: pfDataType, writer_rank + character(len=:), allocatable :: fname_by_writer integer :: STATUS type (StringIntegerMap), save :: RstCollections @@ -3564,13 +3556,15 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) endif lat = MAPL_Range(x0,x1,arrdes%JM_WORLD) - if (arrdes%write_restart_by_face) then - call cf%add_dimension('lat',arrdes%im_world,rc=status) + if (arrdes%split_checkpoint) then + call cf%add_dimension('lat',arrdes%jm_world/arrdes%num_writers,rc=status) _VERIFY(status) block - integer :: j0, j1 - j0 = (arrdes%face_index -1)*arrdes%im_world+1 - j1 = arrdes%face_index * arrdes%im_world + integer :: j0, j1, block_size,ny + ny = size(arrdes%jn) + block_size = ny/arrdes%num_writers + j0 = arrdes%j1(arrdes%myrow+1) + j1 = arrdes%jn(arrdes%myrow+1+block_size-1) allocate(coordinate_data,source=lat(j0:j1)) end block allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) @@ -3909,11 +3903,16 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) call formatter%write(cf,rc=status) _VERIFY(STATUS) else - if (arrdes%write_restart_by_face) then - fname_by_face = get_fname_by_face(trim(filename),arrdes%face_index) - call formatter%create_par(trim(fname_by_face),comm=arrdes%face_writers_comm,info=info,rc=status) + if (arrdes%split_checkpoint) then + call mpi_comm_rank(arrdes%writers_comm,writer_rank,status) + _VERIFY(STATUS) + fname_by_writer = get_fname_by_face(trim(filename),writer_rank) + call formatter%create(trim(fname_by_writer),rc=status) _VERIFY(status) - call cf%add_attribute("Cubed_Sphere_Face_Index", arrdes%face_index, _RC) + if (writer_rank == 0) then + call create_control_file(filename,arrdes%im_world,arrdes%num_writers,rc) + end if + !call cf%add_attribute("Cubed_Sphere_Face_Index", arrdes%face_index, _RC) else call formatter%create_par(trim(filename),comm=arrdes%writers_comm,info=info,rc=status) _VERIFY(status) @@ -4007,6 +4006,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) DEALOC_(MASK) end if + _RETURN(ESMF_SUCCESS) contains @@ -4031,6 +4031,26 @@ subroutine add_fvar(cf,vname,vtype,dims,units,long_name,rc) end subroutine add_fvar + subroutine create_control_file(filename,jm_world,num_writers,rc) + character(len=*), intent(in) :: filename + integer, intent(in) :: jm_world + integer, intent(in) :: num_writers + integer, intent(out), optional :: rc + integer :: status + type(ESMF_HConfig) :: hconfig + character(len=4) :: resolution + character(len=3) :: writers + character(len=128) :: yaml_content + + write(resolution,'(I4)')jm_world + write(writers,'(I3)')num_writers + yaml_content = "{j_size: "//trim(resolution)//", num_files: "//trim(writers)//"}" + hconfig = ESMF_HConfigCreate(content=yaml_content,_RC) + call ESMF_HConfigFileSave(hconfig,trim(filename),_RC) + _RETURN(_SUCCESS) + + end subroutine + end subroutine MAPL_BundleWriteNCPar subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWriteNoRestart, oClients, RC) @@ -4627,24 +4647,25 @@ subroutine MAPL_NCIOParseTimeUnits ( TimeUnits, year, month, day, hour, min, sec return end subroutine MAPL_NCIOParseTimeUnits - ! WJ notes: To avoid changing gcm_run.j script, insert "_face_x_", not append - function get_fname_by_face(fname, face) result(name) + ! WJ notes: To avoid changing gcm_run.j script, insert "_split_x_", not append + function get_fname_by_face(fname, rank) result(name) character(len=:), allocatable :: name character(len=*), intent(in) :: fname - integer, intent(in) :: face + integer, intent(in) :: rank integer :: i - i= index(fname,'_checkpoint') - if (i /= 0) then - name = fname(1:i-1)//'_face_'//i_to_string(face)//trim(fname(i:)) - return - end if - i= index(fname,'_rst') - if (i /= 0) then - name = fname(1:i-1)//'_face_'//i_to_string(face)//trim(fname(i:)) - return - endif - name = trim(fname)//'_face_'//i_to_string(face) + name = trim(fname)//"_"//i_to_string(rank) + !i= index(fname,'_checkpoint') + !if (i /= 0) then + !name = fname(1:i-1)//'_split_'//i_to_string(rank)//trim(fname(i:)) + !return + !end if + !i= index(fname,'_rst') + !if (i /= 0) then + !name = fname(1:i-1)//'_split_'//i_to_string(rank)//trim(fname(i:)) + !return + !endif + !name = trim(fname)//'_split_'//i_to_string(rank) end function get_fname_by_face diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 656c700c500d..6c1b565bc5b9 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -1,4 +1,4 @@ -!------------------------------------------------------------------------------ +!!------------------------------------------------------------------------------ ! Global Modeling and Assimilation Office (GMAO) ! ! Goddard Earth Observing System (GEOS) ! ! MAPL Component ! @@ -1026,8 +1026,7 @@ recursive subroutine MAPL_GenericInitialize ( GC, import, EXPORT, CLOCK, RC ) MYGRID%NX0 = mod(MYGRID%MYID,MYGRID%NX) + 1 MYGRID%NY0 = MYGRID%MYID/MYGRID%NX + 1 #endif - - call handle_readers_and_writers(_RC) + call set_checkpoint_restart_options(_RC) #ifdef DEBUG print *,"dbg: grid global max=",counts @@ -1164,15 +1163,12 @@ logical function grid_is_valid(gc, grid, rc) _RETURN(ESMF_SUCCESS) end function grid_is_valid - subroutine handle_readers_and_writers(rc) + subroutine set_checkpoint_restart_options(rc) integer, optional, intent(out) :: rc - integer :: num_readers, ny_by_readers - integer :: num_writers, ny_by_writers - character(len=ESMF_MAXSTR) :: write_restart_by_face - character(len=ESMF_MAXSTR) :: read_restart_by_face + integer :: num_readers, num_writers + character(len=ESMF_MAXSTR) :: split_restart, split_checkpoint character(len=ESMF_MAXSTR) :: write_restart_by_oserver - integer :: color integer :: j integer :: status @@ -1181,99 +1177,98 @@ subroutine handle_readers_and_writers(rc) default=1, _RC) call MAPL_GetResource( STATE, num_writers, Label="NUM_WRITERS:", & default=1, _RC) - call MAPL_GetResource( STATE, write_restart_by_face, Label="WRITE_RESTART_BY_FACE:", & + call MAPL_GetResource( STATE, split_checkpoint, Label="SPLIT_CHECKPOINT:", & default='NO', _RC) - write_restart_by_face = ESMF_UtilStringUpperCase(write_restart_by_face,_RC) + call MAPL_GetResource( STATE, split_restart, Label="SPLIT_RESTART:", & + default='NO', _RC) + split_restart = ESMF_UtilStringUpperCase(split_restart,_RC) + split_checkpoint = ESMF_UtilStringUpperCase(split_checkpoint,_RC) call MAPL_GetResource( STATE, write_restart_by_oserver, Label="WRITE_RESTART_BY_OSERVER:", & default='NO', _RC) write_restart_by_oserver = ESMF_UtilStringUpperCase(write_restart_by_oserver,_RC) - call MAPL_GetResource( STATE, read_restart_by_face, Label="READ_RESTART_BY_FACE:", & - default='NO', _RC) - read_restart_by_face = ESMF_UtilStringUpperCase(read_restart_by_face,_RC) - if (trim(write_restart_by_oserver) == 'YES') then ! reset other choices ! io_rank 0 becomes the root num_writers = 1 - write_restart_by_face = 'NO' + split_checkpoint = 'NO' mygrid%write_restart_by_oserver = .true. endif mygrid%comm = comm mygrid%num_readers = num_readers mygrid%num_writers = num_writers - if (trim(write_restart_by_face) == 'YES') then - mygrid%write_restart_by_face = .true. + if (trim(split_restart) == 'YES') then + mygrid%split_restart = .true. endif - if (trim(read_restart_by_face) == 'YES') then - mygrid%read_restart_by_face = .true. + if (trim(split_checkpoint) == 'YES') then + mygrid%split_checkpoint = .true. endif - ! Y-dir communicators - color = MYGRID%NX0 - call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%Ycomm, status) - - ! X-dir communicators - color = MYGRID%NY0 - call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%Xcomm, status) - - ! READER-communicator - if( num_readers>MYGRID%ny .or. mod(MYGRID%ny,num_readers)/=0 ) then - if (MAPL_AM_I_Root(VM)) then - print * - print *,'***********************************************************' - print *,'Error! NUM_READERS must be <= MYGRID%ny: ',MYGRID%ny - print *,' and NUM_READERS must divide evenly into MYGRID%ny' - print *,'***********************************************************' - print * - end if - endif - _ASSERT(num_readers<=MYGRID%ny,'needs informative message') - _ASSERT(mod(MYGRID%ny,num_readers)==0,'needs informative message') - ny_by_readers = MYGRID%ny/num_readers - if (mod(MYGRID%MYID,MYGRID%nx*MYGRID%ny/num_readers) == 0) then - color = 0 - else - color = MPI_UNDEFINED - endif - call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%readers_comm, status) - if (num_readers==MYGRID%ny) then - mygrid%IOscattercomm = mygrid%Xcomm - else - j = MYGRID%NY0 - mod(MYGRID%NY0-1,ny_by_readers) - call MPI_COMM_SPLIT(COMM, j, MYGRID%MYID, mygrid%IOscattercomm, status) - endif - - ! WRITER-communicator - if( num_writers>MYGRID%ny .or. mod(MYGRID%ny,num_writers)/=0 ) then - if (MAPL_AM_I_Root(VM)) then - print * - print *,'***********************************************************' - print *,'Error! NUM_WRITERS must be <= MYGRID%ny: ',MYGRID%ny - print *,' and NUM_WRITERS must divide evenly into MYGRID%ny' - print *,'***********************************************************' - print * - end if - endif - _ASSERT(num_writers<=MYGRID%ny,'needs informative message') - _ASSERT(mod(MYGRID%ny,num_writers)==0,'needs informative message') - ny_by_writers = MYGRID%ny/num_writers - if (mod(MYGRID%MYID,MYGRID%nx*MYGRID%ny/num_writers) == 0) then - color = 0 - else - color = MPI_UNDEFINED - endif - call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%writers_comm, status) - if (num_writers==MYGRID%ny) then - mygrid%IOgathercomm = mygrid%Xcomm - else - j = MYGRID%NY0 - mod(MYGRID%NY0-1,ny_by_writers) - call MPI_COMM_SPLIT(COMM, j, MYGRID%MYID, mygrid%IOgathercomm, status) - endif + !! Y-dir communicators + !color = MYGRID%NX0 + !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%Ycomm, status) + + !! X-dir communicators + !color = MYGRID%NY0 + !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%Xcomm, status) + + !! READER-communicator + !if( num_readers>MYGRID%ny .or. mod(MYGRID%ny,num_readers)/=0 ) then + !if (MAPL_AM_I_Root(VM)) then + !print * + !print *,'***********************************************************' + !print *,'Error! NUM_READERS must be <= MYGRID%ny: ',MYGRID%ny + !print *,' and NUM_READERS must divide evenly into MYGRID%ny' + !print *,'***********************************************************' + !print * + !end if + !endif + !_ASSERT(num_readers<=MYGRID%ny,'needs informative message') + !_ASSERT(mod(MYGRID%ny,num_readers)==0,'needs informative message') + !ny_by_readers = MYGRID%ny/num_readers + !if (mod(MYGRID%MYID,MYGRID%nx*MYGRID%ny/num_readers) == 0) then + !color = 0 + !else + !color = MPI_UNDEFINED + !endif + !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%readers_comm, status) + !if (num_readers==MYGRID%ny) then + !mygrid%IOscattercomm = mygrid%Xcomm + !else + !j = MYGRID%NY0 - mod(MYGRID%NY0-1,ny_by_readers) + !call MPI_COMM_SPLIT(COMM, j, MYGRID%MYID, mygrid%IOscattercomm, status) + !endif + + !! WRITER-communicator + !if( num_writers>MYGRID%ny .or. mod(MYGRID%ny,num_writers)/=0 ) then + !if (MAPL_AM_I_Root(VM)) then + !print * + !print *,'***********************************************************' + !print *,'Error! NUM_WRITERS must be <= MYGRID%ny: ',MYGRID%ny + !print *,' and NUM_WRITERS must divide evenly into MYGRID%ny' + !print *,'***********************************************************' + !print * + !end if + !endif + !_ASSERT(num_writers<=MYGRID%ny,'needs informative message') + !_ASSERT(mod(MYGRID%ny,num_writers)==0,'needs informative message') + !ny_by_writers = MYGRID%ny/num_writers + !if (mod(MYGRID%MYID,MYGRID%nx*MYGRID%ny/num_writers) == 0) then + !color = 0 + !else + !color = MPI_UNDEFINED + !endif + !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%writers_comm, status) + !if (num_writers==MYGRID%ny) then + !mygrid%IOgathercomm = mygrid%Xcomm + !else + !j = MYGRID%NY0 - mod(MYGRID%NY0-1,ny_by_writers) + !call MPI_COMM_SPLIT(COMM, j, MYGRID%MYID, mygrid%IOgathercomm, status) + !endif _RETURN(ESMF_SUCCESS) - end subroutine handle_readers_and_writers + end subroutine set_checkpoint_restart_options recursive subroutine initialize_children_and_couplers(rc) integer, optional, intent(out) :: rc @@ -5752,11 +5747,6 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli integer :: UNIT integer :: YYYY, MM, DD, H, M, S type(ESMF_Time) :: currentTime - ! integer :: IM_WORLD - ! integer :: JM_WORLD - ! integer :: MONTH, DAY, HOUR, MINUTE - ! integer :: YEAR, SECOND - ! type (ESMF_Time) :: CURRENTTIME integer :: HEADER(6), DimCount logical :: AmWriter type(ArrDescr) :: ArrDes @@ -5765,14 +5755,10 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli type(ESMF_Grid) :: TILEGRID integer :: COUNTS(2) - integer :: io_nodes, io_rank + integer :: io_rank integer :: attr character(len=MPI_MAX_INFO_VAL ) :: romio_cb_write logical :: nwrgt1 - !real(kind=ESMF_KIND_R8) :: itime_beg, itime_end - !real(kind=ESMF_KIND_R8),save :: total_time = 0.0d0 - !logical :: amIRoot - !type (ESMF_VM) :: vm logical :: empty ! Check if state is empty. If "yes", simply return @@ -5807,8 +5793,6 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli call ESMF_GridGet(MPL%GRID%ESMFGRID, dimCount=dimCount, RC=status) _VERIFY(status) - AmWriter = mpl%grid%writers_comm/=MPI_COMM_NULL - call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) _VERIFY(status) TILE: if(IAND(ATTR, MAPL_AttrTile) /= 0) then @@ -5821,49 +5805,31 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli call MAPL_GridGet(TILEGRID, globalCellCountPerDim=COUNTS, RC=status) _VERIFY(status) - call ArrDescrSet(arrdes, & - writers_comm = mpl%grid%writers_comm,& - iogathercomm = mpl%grid%comm ) - - if(AmWriter) then - - call MPI_COMM_SIZE(mpl%grid%writers_comm, io_nodes, status) - _VERIFY(status) - call MPI_COMM_RANK(mpl%grid%writers_comm, io_rank, status) - _VERIFY(status) - - endif - call ArrDescrSet(arrdes, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = COUNTS(1), & jm_world = COUNTS(2) ) - else - - AmWriter = mpl%grid%writers_comm/=MPI_COMM_NULL + call ArrDescrCreateWriterComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) + call ArrDescrSet(arrdes, & + iogathercomm = mpl%grid%comm ) - if (AmWriter) then - call MPI_COMM_SIZE(mpl%grid%writers_comm, io_nodes, status) - _VERIFY(status) - call MPI_COMM_RANK(mpl%grid%writers_comm, io_rank, status) - _VERIFY(status) - endif + else call ArrDescrSet(arrdes, offset, & - writers_comm = mpl%grid%writers_comm, & - iogathercomm = mpl%grid%iogathercomm, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = mpl%grid%im_world, & jm_world = mpl%grid%jm_world) + call ArrDescrCreateWriterComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) end if TILE !@ call MPI_Barrier(mpl%grid%comm, status) !@ _VERIFY(status) arrdes%offset = 0 + AmWriter = arrdes%writers_comm /= MPI_COMM_NULL if (AmWriter) then call MPI_Info_create(info, status) @@ -5873,6 +5839,8 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli _VERIFY(status) call MPI_Info_set(info, "romio_cb_write", trim(romio_cb_write), status) _VERIFY(status) + call MPI_COMM_RANK(mpl%grid%writers_comm, io_rank, status) + _VERIFY(status) if (io_rank == 0) then print *,'Using parallel IO for writing file: ',trim(FILENAME) ! make sure file exists @@ -5882,13 +5850,11 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli call MPI_FILE_CLOSE(UNIT, status) _VERIFY(status) end if - call MPI_Barrier(mpl%grid%writers_comm, status) + call MPI_Barrier(arrdes%writers_comm, status) _VERIFY(status) - call MPI_FILE_OPEN(mpl%grid%writers_comm, FILENAME, MPI_MODE_WRONLY, & + call MPI_FILE_OPEN(arrdes%writers_comm, FILENAME, MPI_MODE_WRONLY, & info, UNIT, status) _VERIFY(status) - !$$ call MPI_Barrier(mpl%grid%writers_comm, status) - !$$ _VERIFY(status) else UNIT=0 endif @@ -5900,7 +5866,6 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli _FAIL('needs informative message') end if #endif - AmWriter = mpl%grid%writers_comm/=MPI_COMM_NULL call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) _VERIFY(status) PNC4_TILE: if(IAND(ATTR, MAPL_AttrTile) /= 0) then @@ -5912,13 +5877,7 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli _VERIFY(status) end if PNC4_TILE arrdes%filename = trim(FILENAME) - if (AmWriter) then - call MPI_COMM_RANK(mpl%grid%writers_comm, io_rank, status) - _VERIFY(status) - if (io_rank == 0) then - print *,'Using parallel NetCDF to write file: ',trim(FILENAME) - end if - endif + if (mapl_am_i_root()) print *,'Using parallel NetCDF to write file: ',trim(FILENAME) else UNIT=0 end if @@ -5973,38 +5932,16 @@ subroutine MAPL_ESMFStateWriteToFile(STATE,CLOCK,FILENAME,FILETYPE,MPL,HDR, oCli _VERIFY(status) if (AmWriter) then - !$$ call MPI_Barrier(mpl%grid%writers_comm, status) - !$$ _VERIFY(status) call MPI_FILE_CLOSE(UNIT, status) _VERIFY(status) call MPI_Info_free(info, status) _VERIFY(status) endif -!@ call MPI_Barrier(mpl%grid%comm, status) -!@ _VERIFY(status) - elseif(filetype=='pnc4') then - !call MPI_Barrier(mpl%grid%comm, status) - !_VERIFY(status) - !itime_beg = MPI_Wtime() - !_VERIFY(status) - call MAPL_VarWriteNCPar(filename,STATE,ArrDes,CLOCK, oClients=oClients, RC=status) _VERIFY(status) - !call MPI_Barrier(mpl%grid%comm, status) - !_VERIFY(status) - !itime_end = MPI_Wtime() - !total_time = total_time + itime_end - itime_beg - !_VERIFY(status) - !call MPI_COMM_RANK(mpl%grid%comm, io_rank, status) - ! _VERIFY(status) - !if (io_rank == 0) then - ! print *,'Time using writing filename: '//trim(filename), ' ', itime_end - itime_beg - ! print *,'Total time writing checkpoint: ', total_time - !end if - elseif(UNIT/=0) then call MAPL_VarWrite(UNIT=UNIT, STATE=STATE, rc=status) @@ -6047,7 +5984,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) type(ESMF_Grid) :: TILEGRID integer :: COUNTS(2) - integer :: io_nodes, io_rank + integer :: io_rank integer :: attr character(len=MPI_MAX_INFO_VAL ) :: romio_cb_read logical :: bootstrapable @@ -6110,24 +6047,24 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) if(INDEX(FNAME,'*') == 0) then if (AmIRoot) then block - character(len=:), allocatable :: fname_by_face + character(len=:), allocatable :: fname_by_reader logical :: fexist integer :: i FileExists = .false. - if (mpl%grid%read_restart_by_face) then + if (mpl%grid%split_restart) then FileExists = .true. - do i = 1,6 ! 6 faces - fname_by_face = get_fname_by_face(trim(fname), i) - inquire(FILE = trim(fname_by_face), EXIST=fexist) + do i = 0,mpl%grid%num_readers-1 + fname_by_reader = get_fname_by_face(trim(fname), i) + inquire(FILE = trim(fname_by_reader), EXIST=fexist) FileExists = FileExists .and. fexist enddo if (FileExists) then ! just pick one face to deduce filetype, only in root - call MAPL_NCIOGetFileType(trim(fname_by_face),isNC4,rc=status) + call MAPL_NCIOGetFileType(trim(fname_by_reader),isNC4,rc=status) _VERIFY(status) endif - deallocate(fname_by_face) + deallocate(fname_by_reader) endif end block if( .not. FileExists) then @@ -6143,8 +6080,8 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _VERIFY(status) if (FileExists) then !if (AmIRoot) then - ! call MAPL_NCIOGetFileType(FNAME,isNC4,rc=status) - ! _VERIFY(status) + !call MAPL_NCIOGetFileType(FNAME,isNC4,rc=status) + !_VERIFY(status) !end if call MAPL_CommsBcast(vm,isNC4,n=1,ROOT=MAPL_Root,rc=status) _VERIFY(status) @@ -6172,12 +6109,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) end if end if - ! if (ignoreEOF) then - ! if (filetype == 'pbinary' .or. filetype == 'PBINARY') then - ! filetype = 'binary' - ! end if - ! end if - ! Open file !---------- @@ -6199,8 +6130,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_GridGet(MPL%GRID%ESMFGRID, dimCount=dimCount, RC=status) _VERIFY(status) - AmReader = mpl%grid%readers_comm/=MPI_COMM_NULL - call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) _VERIFY(status) TILE: if(IAND(ATTR, MAPL_AttrTile) /= 0) then @@ -6213,47 +6142,29 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call MAPL_GridGet(TILEGRID, globalCellCountPerDim=COUNTS, RC=status) _VERIFY(status) - call ArrDescrSet(arrdes, & - readers_comm = mpl%grid%readers_comm, & - ioscattercomm = mpl%grid%comm ) - - if(AmReader) then - - call MPI_COMM_SIZE(mpl%grid%readers_comm, io_nodes, status) - _VERIFY(status) - call MPI_COMM_RANK(mpl%grid%readers_comm, io_rank, status) - _VERIFY(status) - - endif - call ArrDescrSet(arrdes, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = COUNTS(1), & jm_world = COUNTS(2) ) + call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) + call ArrDescrSet(arrdes, ioscattercomm = mpl%grid%comm ) else - if (AmReader) then - call MPI_COMM_SIZE(mpl%grid%readers_comm, io_nodes, status) - _VERIFY(status) - call MPI_COMM_RANK(mpl%grid%readers_comm, io_rank, status) - _VERIFY(status) - endif - call ArrDescrSet(arrdes, offset, & - readers_comm = mpl%grid%readers_comm, & - ioscattercomm = mpl%grid%ioscattercomm, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = mpl%grid%im_world, & jm_world = mpl%grid%jm_world) + call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) end if TILE UNIT=-999 offset = 0 + AmReader = arrdes%readers_comm/=MPI_COMM_NULL if (AmReader) then call MPI_Info_create(info, status) _VERIFY(status) @@ -6262,6 +6173,8 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _VERIFY(status) call MPI_Info_set(info, "romio_cb_read", trim(romio_cb_read), status) _VERIFY(status) + call MPI_COMM_RANK(mpl%grid%readers_comm, io_rank, status) + _VERIFY(status) if (io_rank == 0) then print *,'Using parallel IO for reading file: ',trim(FNAME) end if @@ -6283,7 +6196,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _FAIL('needs informative message') end if #endif - AmReader = mpl%grid%readers_comm/=MPI_COMM_NULL call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) _VERIFY(status) PNC4_TILE: if(IAND(ATTR, MAPL_AttrTile) /= 0) then @@ -6297,17 +6209,11 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_AttributeGet(MPL%GRID%ESMFGRID,'GridType',value=grid_type,rc=status) _VERIFY(status) end if - _ASSERT(grid_is_consistent(grid_type, fname), "grid in the file is different from app's grid") + !_ASSERT(grid_is_consistent(grid_type, fname), "grid in the file is different from app's grid") call ArrDescrSetNCPar(arrdes,MPL,num_readers=mpl%grid%num_readers,RC=status) _VERIFY(status) end if PNC4_TILE - if (mpl%grid%readers_comm/=MPI_COMM_NULL) then - call MPI_COMM_RANK(mpl%grid%readers_comm, io_rank, status) - _VERIFY(status) - if (io_rank == 0) then - print *,'Using parallel NetCDF to read file: ',trim(FNAME) - end if - endif + if (mapl_am_i_root())print*,'Using parallel NetCDF to read file: ',trim(FNAME) else UNIT=0 end if @@ -6363,33 +6269,33 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _RETURN(ESMF_SUCCESS) - contains - function grid_is_consistent(grid_type, fname) result( consistent) - logical :: consistent - character(*), intent(in) :: grid_type - character(*), intent(in) :: fname - !note this only works for geos cubed-sphere restarts currently because of - !possible insufficent metadata in the other restarts to support the other grid factories - class(AbstractGridFactory), pointer :: app_factory - class (AbstractGridFactory), allocatable :: file_factory - character(len=:), allocatable :: fname_by_face - logical :: fexist - - consistent = .True. - if (trim(grid_type) == 'Cubed-Sphere') then - app_factory => get_factory(MPL%GRID%ESMFGRID) - ! at this point, arrdes%read_restart_by_face is not initialized - ! pick the first face - fname_by_face = get_fname_by_face(trim(fname), 1) - inquire(FILE = trim(fname_by_face), EXIST=fexist) - if(fexist) then - allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) - else - allocate(file_factory,source=grid_manager%make_factory(trim(fname))) - endif - consistent = file_factory%physical_params_are_equal(app_factory) - end if - end function + !contains + !function grid_is_consistent(grid_type, fname) result( consistent) + !logical :: consistent + !character(*), intent(in) :: grid_type + !character(*), intent(in) :: fname + !!note this only works for geos cubed-sphere restarts currently because of + !!possible insufficent metadata in the other restarts to support the other grid factories + !class(AbstractGridFactory), pointer :: app_factory + !class (AbstractGridFactory), allocatable :: file_factory + !character(len=:), allocatable :: fname_by_face + !logical :: fexist + + !consistent = .True. + !if (trim(grid_type) == 'Cubed-Sphere') then + !app_factory => get_factory(MPL%GRID%ESMFGRID) + !! at this point, arrdes%read_restart_by_face is not initialized + !! pick the first face + !fname_by_face = get_fname_by_face(trim(fname), 1) + !inquire(FILE = trim(fname_by_face), EXIST=fexist) + !if(fexist) then + !allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) + !else + !allocate(file_factory,source=grid_manager%make_factory(trim(fname))) + !endif + !consistent = file_factory%physical_params_are_equal(app_factory) + !end if + !end function end subroutine MAPL_ESMFStateReadFromFile @@ -11091,41 +10997,50 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, call MAPL_GridGet(TILEGRID,globalCellCountPerDim=COUNTS,RC=status) _VERIFY(status) call ArrDescrSet(arrdes, offset_local, & - readers_comm = mpl%grid%readers_comm, & - ioscattercomm = mpl%grid%comm, & + !readers_comm = mpl%grid%readers_comm, & + !ioscattercomm = mpl%grid%comm, & writers_comm = mpl%grid%writers_comm, & iogathercomm = mpl%grid%comm, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = COUNTS(1), & jm_world = COUNTS(2)) - arrdes%ycomm = mpl%grid%Ycomm - arrdes%xcomm = mpl%grid%Xcomm + !arrdes%ycomm = mpl%grid%Ycomm + + !arrdes%xcomm = mpl%grid%Xcomm arrdes%NY0 = mpl%grid%NY0 arrdes%NX0 = mpl%grid%NX0 arrdes%tile=.true. arrdes%grid=tilegrid + call ArrDescrCreateWriterComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) + call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) + arrdes%iogathercomm = mpl%grid%comm else call MAPL_GridGet(mpl%grid%ESMFGRID,globalCellCountPerDim=CCPD,RC=status) _VERIFY(status) km_world = CCPD(3) call ArrDescrSet(arrdes, offset_local, & - readers_comm = mpl%grid%readers_comm, & - ioscattercomm = mpl%grid%ioscattercomm, & - writers_comm = mpl%grid%writers_comm, & - iogathercomm = mpl%grid%iogathercomm, & + !readers_comm = mpl%grid%readers_comm, & + !ioscattercomm = mpl%grid%ioscattercomm, & + !writers_comm = mpl%grid%writers_comm, & + !iogathercomm = mpl%grid%iogathercomm, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = mpl%grid%im_world, & jm_world = mpl%grid%jm_world, & lm_world = km_world) - arrdes%ycomm = mpl%grid%Ycomm - arrdes%xcomm = mpl%grid%Xcomm + !arrdes%ycomm = mpl%grid%Ycomm + !call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,status) + _VERIFY(status) + !arrdes%xcomm = mpl%grid%Xcomm arrdes%NY0 = mpl%grid%NY0 arrdes%NX0 = mpl%grid%NX0 arrdes%tile=.false. arrdes%grid=MPL%GRID%ESMFGRID - call set_arrdes_by_face() + call ArrDescrCreateWriterComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) + call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) + call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,status) + endif call MAPL_GetResource(MPL, romio_cb_read, Label="ROMIO_CB_READ:", default="automatic", RC=status) _VERIFY(status) @@ -11139,38 +11054,11 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, if (present(num_readers)) arrdes%num_readers=num_readers if (present(num_writers)) arrdes%num_writers=num_writers arrdes%write_restart_by_oserver = mpl%grid%write_restart_by_oserver + arrdes%split_restart = mpl%grid%split_restart + arrdes%split_checkpoint = mpl%grid%split_checkpoint _RETURN(ESMF_SUCCESS) - contains - subroutine set_arrdes_by_face() - integer :: color, key - character(len=ESMF_MAXSTR) :: Iam="ArrDescrSetNCPar_face" - integer :: status - - if (mpl%grid%im_world /= mpl%grid%jm_world/6) return ! only apply to cube - - color = (arrdes%j1(mpl%grid%NY0)-1)/mpl%grid%im_world + 1 - arrdes%face_index = color - key = 1 - if ( mpl%grid%write_restart_by_face) then - arrdes%write_restart_by_face = .true. - if (mpl%grid%writers_comm /= MPI_COMM_NULL) then - call MPI_COMM_SPLIT( mpl%grid%writers_comm,color,key,arrdes%face_writers_comm, status) - _VERIFY(status) - endif - endif - - if ( mpl%grid%read_restart_by_face) then - arrdes%read_restart_by_face = .true. - if (mpl%grid%readers_comm /= MPI_COMM_NULL) then - call MPI_COMM_SPLIT( mpl%grid%readers_comm,color,key,arrdes%face_readers_comm, status) - _VERIFY(status) - endif - endif - - end subroutine set_arrdes_by_face - end subroutine ArrDescrSetNCPar subroutine MAPL_GetLogger_meta(meta, lgr, rc) From b17510b662ed04a6e43289809ded94c3dde8200a Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 28 Sep 2023 14:29:07 -0400 Subject: [PATCH 003/141] more bug fixes --- generic/MAPL_Generic.F90 | 78 ++++++++++++++++++++++------------------ 1 file changed, 44 insertions(+), 34 deletions(-) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 6c1b565bc5b9..fb086ac42a3b 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -1179,9 +1179,9 @@ subroutine set_checkpoint_restart_options(rc) default=1, _RC) call MAPL_GetResource( STATE, split_checkpoint, Label="SPLIT_CHECKPOINT:", & default='NO', _RC) - call MAPL_GetResource( STATE, split_restart, Label="SPLIT_RESTART:", & - default='NO', _RC) - split_restart = ESMF_UtilStringUpperCase(split_restart,_RC) + !call MAPL_GetResource( STATE, split_restart, Label="SPLIT_RESTART:", & + !default='NO', _RC) + split_restart = 'NO' split_checkpoint = ESMF_UtilStringUpperCase(split_checkpoint,_RC) call MAPL_GetResource( STATE, write_restart_by_oserver, Label="WRITE_RESTART_BY_OSERVER:", & @@ -1199,9 +1199,9 @@ subroutine set_checkpoint_restart_options(rc) mygrid%comm = comm mygrid%num_readers = num_readers mygrid%num_writers = num_writers - if (trim(split_restart) == 'YES') then - mygrid%split_restart = .true. - endif + !if (trim(split_restart) == 'YES') then + !mygrid%split_restart = .true. + !endif if (trim(split_checkpoint) == 'YES') then mygrid%split_checkpoint = .true. endif @@ -5999,7 +5999,9 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) integer :: isNC4 logical :: isPresent character(len=ESMF_MAXSTR) :: grid_type - logical :: empty + logical :: empty, split_restart + integer :: num_files + type(ESMF_HConfig) :: hconfig _UNUSED_DUMMY(CLOCK) @@ -6043,18 +6045,25 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) nwrgt1 = (mpl%grid%num_readers > 1) - + split_restart = .false. + isNC4 = -100 if(INDEX(FNAME,'*') == 0) then if (AmIRoot) then + hconfig = ESMF_HConfigCreate(filename = trim(filename), rc=status) + if (status == ESMF_SUCCESS) then + _ASSERT(ESMF_HConfigIsDefined(hconfig,keyString="num_files"),"if input file is split must supply num_files") + num_files = ESMF_HConfigAsI4(hconfig,keystring="num_files",_RC) + split_restart = .true. + end if block character(len=:), allocatable :: fname_by_reader logical :: fexist integer :: i FileExists = .false. - if (mpl%grid%split_restart) then + if (split_restart) then FileExists = .true. - do i = 0,mpl%grid%num_readers-1 + do i = 0,num_files-1 fname_by_reader = get_fname_by_face(trim(fname), i) inquire(FILE = trim(fname_by_reader), EXIST=fexist) FileExists = FileExists .and. fexist @@ -6065,26 +6074,27 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _VERIFY(status) endif deallocate(fname_by_reader) + else + inquire(FILE = FNAME, EXIST=FileExists) + if (FileExists) then + call MAPL_NCIOGetFileType(FNAME,isNC4,rc=status) + _VERIFY(status) + endif endif end block - if( .not. FileExists) then - inquire(FILE = FNAME, EXIST=FileExists) - if (FileExists) then - call MAPL_NCIOGetFileType(FNAME,isNC4,rc=status) - _VERIFY(status) - endif - endif + end if + call MAPL_CommsBcast(vm,split_restart,n=1,ROOT=MAPL_Root,_RC) + + call MAPL_CommsBcast(vm, fileExists, n=1, ROOT=MAPL_Root, _RC) + call MAPL_CommsBcast(vm, isNC4, n=1, ROOT=MAPL_Root, _RC) + if (split_restart) then + call MAPL_CommsBcast(vm, num_files, n=1, ROOT=MAPL_Root, _RC) + call MAPL_CommsBcast(vm, split_restart, n=1, ROOT=MAPL_Root, _RC) + mpl%grid%num_readers = num_files + mpl%grid%split_restart = split_restart end if - call MAPL_CommsBcast(vm, fileExists, n=1, ROOT=MAPL_Root, rc=status) - _VERIFY(status) if (FileExists) then - !if (AmIRoot) then - !call MAPL_NCIOGetFileType(FNAME,isNC4,rc=status) - !_VERIFY(status) - !end if - call MAPL_CommsBcast(vm,isNC4,n=1,ROOT=MAPL_Root,rc=status) - _VERIFY(status) if (isNC4 == 0) then filetype = 'pnc4' else @@ -6098,7 +6108,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) else FileExists = MAPL_MemFileInquire(NAME=FNAME) end if - if (.not. FileExists) then if (.not. bootstrapable .or. restartRequired) then call WRITE_PARALLEL('ERROR: Required restart '//trim(FNAME)//' does not exist!') @@ -6108,7 +6117,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _RETURN(ESMF_SUCCESS) end if end if - ! Open file !---------- @@ -6147,7 +6155,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = COUNTS(1), & jm_world = COUNTS(2) ) - call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) + call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) call ArrDescrSet(arrdes, ioscattercomm = mpl%grid%comm ) else @@ -6157,7 +6165,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = mpl%grid%im_world, & jm_world = mpl%grid%jm_world) - call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) + call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) end if TILE @@ -6218,7 +6226,6 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) UNIT=0 end if - ! Skip Header !------------ @@ -10999,8 +11006,8 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, call ArrDescrSet(arrdes, offset_local, & !readers_comm = mpl%grid%readers_comm, & !ioscattercomm = mpl%grid%comm, & - writers_comm = mpl%grid%writers_comm, & - iogathercomm = mpl%grid%comm, & + !writers_comm = mpl%grid%writers_comm, & + !iogathercomm = mpl%grid%comm, & i1 = mpl%grid%i1, in = mpl%grid%in, & j1 = mpl%grid%j1, jn = mpl%grid%jn, & im_world = COUNTS(1), & @@ -11015,6 +11022,9 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, call ArrDescrCreateWriterComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) arrdes%iogathercomm = mpl%grid%comm + arrdes%ioscattercomm = mpl%grid%comm + arrdes%split_restart = .false. + arrdes%split_checkpoint = .false. else call MAPL_GridGet(mpl%grid%ESMFGRID,globalCellCountPerDim=CCPD,RC=status) _VERIFY(status) @@ -11040,6 +11050,8 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, call ArrDescrCreateWriterComm(arrdes,mpl%grid%comm,mpl%grid%num_writers,_RC) call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,status) + arrdes%split_restart = mpl%grid%split_restart + arrdes%split_checkpoint = mpl%grid%split_checkpoint endif call MAPL_GetResource(MPL, romio_cb_read, Label="ROMIO_CB_READ:", default="automatic", RC=status) @@ -11054,8 +11066,6 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, if (present(num_readers)) arrdes%num_readers=num_readers if (present(num_writers)) arrdes%num_writers=num_writers arrdes%write_restart_by_oserver = mpl%grid%write_restart_by_oserver - arrdes%split_restart = mpl%grid%split_restart - arrdes%split_checkpoint = mpl%grid%split_checkpoint _RETURN(ESMF_SUCCESS) From 4362894dd8c2ef7ce7c923027c1cc8091d0969ad Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 28 Sep 2023 16:26:17 -0400 Subject: [PATCH 004/141] more bug fixes --- base/NCIO.F90 | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 1010f6ccd79f..a9531a460800 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -1067,7 +1067,11 @@ subroutine MAPL_VarReadNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, RC) _VERIFY(STATUS) start(1) = 1 - start(2) = arrdes%j1(myrow+1) + if (arrdes%split_restart) then + start(2) = 1 + else + start(2) = arrdes%j1(myrow+1) + end if start(3) = 1 if (present(lev)) start(3) = lev start(4) = 1 @@ -2578,7 +2582,11 @@ subroutine MAPL_VarReadNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, RC) _VERIFY(STATUS) start(1) = 1 - start(2) = arrdes%j1(myrow+1) + if (arrdes%split_restart) then + start(2) = 1 + else + start(2) = arrdes%j1(myrow+1) + end if start(3) = 1 if (present(lev)) start(3)=lev start(4) = 1 @@ -2854,7 +2862,7 @@ subroutine MAPL_StateVarReadNCPar(filename, STATE, arrdes, bootstrapable, NAME, logical :: tile integer :: nVarFile, ncid - character(len=ESMF_MAXSTR), pointer :: VarNamesFile(:) => null() + character(len=ESMF_MAXSTR), allocatable :: VarNamesFile(:) type(ESMF_VM) :: VM logical :: foundInFile integer :: dna @@ -4268,11 +4276,10 @@ subroutine MAPL_NCIOGetFileType(filename,filetype,rc) integer :: unit integer :: i, cwrd logical :: typehdf5 + character(len=12) :: fmt - - UNIT = 10 INQUIRE(IOLENGTH=IREC) WORD - open (UNIT=UNIT, FILE=FILENAME, FORM='unformatted', ACCESS='DIRECT', RECL=IREC, IOSTAT=status) + open (NEWUNIT=UNIT, FILE=FILENAME, FORM='unformatted', ACCESS='DIRECT', RECL=IREC, IOSTAT=status) _VERIFY(STATUS) ! Read first 8 characters and compare with HDF5 signature From cd6c99e1a3377d28243a723938282ccdf311f0f6 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 29 Sep 2023 10:40:21 -0400 Subject: [PATCH 005/141] remove commented out code --- generic/MAPL_Generic.F90 | 70 +--------------------------------------- 1 file changed, 1 insertion(+), 69 deletions(-) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index fb086ac42a3b..1a70fa2d1c59 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -1167,7 +1167,7 @@ subroutine set_checkpoint_restart_options(rc) integer, optional, intent(out) :: rc integer :: num_readers, num_writers - character(len=ESMF_MAXSTR) :: split_restart, split_checkpoint + character(len=ESMF_MAXSTR) :: split_checkpoint character(len=ESMF_MAXSTR) :: write_restart_by_oserver integer :: j @@ -1179,9 +1179,6 @@ subroutine set_checkpoint_restart_options(rc) default=1, _RC) call MAPL_GetResource( STATE, split_checkpoint, Label="SPLIT_CHECKPOINT:", & default='NO', _RC) - !call MAPL_GetResource( STATE, split_restart, Label="SPLIT_RESTART:", & - !default='NO', _RC) - split_restart = 'NO' split_checkpoint = ESMF_UtilStringUpperCase(split_checkpoint,_RC) call MAPL_GetResource( STATE, write_restart_by_oserver, Label="WRITE_RESTART_BY_OSERVER:", & @@ -1199,74 +1196,9 @@ subroutine set_checkpoint_restart_options(rc) mygrid%comm = comm mygrid%num_readers = num_readers mygrid%num_writers = num_writers - !if (trim(split_restart) == 'YES') then - !mygrid%split_restart = .true. - !endif if (trim(split_checkpoint) == 'YES') then mygrid%split_checkpoint = .true. endif - - !! Y-dir communicators - !color = MYGRID%NX0 - !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%Ycomm, status) - - !! X-dir communicators - !color = MYGRID%NY0 - !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%Xcomm, status) - - !! READER-communicator - !if( num_readers>MYGRID%ny .or. mod(MYGRID%ny,num_readers)/=0 ) then - !if (MAPL_AM_I_Root(VM)) then - !print * - !print *,'***********************************************************' - !print *,'Error! NUM_READERS must be <= MYGRID%ny: ',MYGRID%ny - !print *,' and NUM_READERS must divide evenly into MYGRID%ny' - !print *,'***********************************************************' - !print * - !end if - !endif - !_ASSERT(num_readers<=MYGRID%ny,'needs informative message') - !_ASSERT(mod(MYGRID%ny,num_readers)==0,'needs informative message') - !ny_by_readers = MYGRID%ny/num_readers - !if (mod(MYGRID%MYID,MYGRID%nx*MYGRID%ny/num_readers) == 0) then - !color = 0 - !else - !color = MPI_UNDEFINED - !endif - !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%readers_comm, status) - !if (num_readers==MYGRID%ny) then - !mygrid%IOscattercomm = mygrid%Xcomm - !else - !j = MYGRID%NY0 - mod(MYGRID%NY0-1,ny_by_readers) - !call MPI_COMM_SPLIT(COMM, j, MYGRID%MYID, mygrid%IOscattercomm, status) - !endif - - !! WRITER-communicator - !if( num_writers>MYGRID%ny .or. mod(MYGRID%ny,num_writers)/=0 ) then - !if (MAPL_AM_I_Root(VM)) then - !print * - !print *,'***********************************************************' - !print *,'Error! NUM_WRITERS must be <= MYGRID%ny: ',MYGRID%ny - !print *,' and NUM_WRITERS must divide evenly into MYGRID%ny' - !print *,'***********************************************************' - !print * - !end if - !endif - !_ASSERT(num_writers<=MYGRID%ny,'needs informative message') - !_ASSERT(mod(MYGRID%ny,num_writers)==0,'needs informative message') - !ny_by_writers = MYGRID%ny/num_writers - !if (mod(MYGRID%MYID,MYGRID%nx*MYGRID%ny/num_writers) == 0) then - !color = 0 - !else - !color = MPI_UNDEFINED - !endif - !call MPI_COMM_SPLIT(COMM, color, MYGRID%MYID, mygrid%writers_comm, status) - !if (num_writers==MYGRID%ny) then - !mygrid%IOgathercomm = mygrid%Xcomm - !else - !j = MYGRID%NY0 - mod(MYGRID%NY0-1,ny_by_writers) - !call MPI_COMM_SPLIT(COMM, j, MYGRID%MYID, mygrid%IOgathercomm, status) - !endif _RETURN(ESMF_SUCCESS) end subroutine set_checkpoint_restart_options From ddba7ab69a99f900ba223b18ce04c726de66da40 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 29 Sep 2023 10:44:00 -0400 Subject: [PATCH 006/141] update changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 71812fc383f8..e70e3c36e03a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files ### Changed @@ -19,6 +20,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Removed ### Deprecated +- The write-by-face option for checkpoint/restart has been depreciated. This has been replaced by a more generic file-per-writer option ## [2.41.0] - 2023-09-22 From 3a8a1ce43bcd13da73b7b84696c3d9f6f597d61f Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 29 Sep 2023 10:56:55 -0400 Subject: [PATCH 007/141] remove uncommented code --- base/NCIO.F90 | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index c3de725dca9c..67474047fce2 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -4606,17 +4606,6 @@ function get_fname_by_face(fname, rank) result(name) integer :: i name = trim(fname)//"_"//i_to_string(rank) - !i= index(fname,'_checkpoint') - !if (i /= 0) then - !name = fname(1:i-1)//'_split_'//i_to_string(rank)//trim(fname(i:)) - !return - !end if - !i= index(fname,'_rst') - !if (i /= 0) then - !name = fname(1:i-1)//'_split_'//i_to_string(rank)//trim(fname(i:)) - !return - !endif - !name = trim(fname)//'_split_'//i_to_string(rank) end function get_fname_by_face From 1be68c9840e935d33aedfb33bd67aa51813ac34c Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 29 Sep 2023 11:06:16 -0400 Subject: [PATCH 008/141] rename routine --- base/NCIO.F90 | 12 ++++++------ generic/MAPL_Generic.F90 | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 67474047fce2..886b586ac8c0 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -38,7 +38,7 @@ module NCIOMod public MAPL_NCIOParseTimeUnits public MAPL_VarRead public MAPL_VarWrite - public get_fname_by_face + public get_fname_by_rank public MAPL_NCIOGetFileType public MAPL_VarReadNCPar public MAPL_VarWriteNCPar @@ -2669,7 +2669,7 @@ subroutine MAPL_BundleReadNCPar(Bundle, arrdes, filename, rc) call MPI_COMM_RANK(arrdes%readers_comm,reader_rank,status) _VERIFY(STATUS) - fname_by_rank = get_fname_by_face(trim(filename),reader_rank) + fname_by_rank = get_fname_by_rank(trim(filename),reader_rank) call formatter%open(trim(fname_by_rank),pFIO_READ,rc=status) _VERIFY(STATUS) else @@ -2833,7 +2833,7 @@ subroutine MAPL_StateVarReadNCPar(filename, STATE, arrdes, bootstrapable, NAME, if (MAPL_AM_I_Root()) then if(arrdes%split_restart) then - fname_by_face = get_fname_by_face(filename, 1) + fname_by_face = get_fname_by_rank(filename, 1) status = NF90_OPEN(trim(fname_by_face),NF90_NOWRITE, ncid) ! just pick one _VERIFY(STATUS) else @@ -3858,7 +3858,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) if (arrdes%split_checkpoint) then call mpi_comm_rank(arrdes%writers_comm,writer_rank,status) _VERIFY(STATUS) - fname_by_writer = get_fname_by_face(trim(filename),writer_rank) + fname_by_writer = get_fname_by_rank(trim(filename),writer_rank) call formatter%create(trim(fname_by_writer),rc=status) _VERIFY(status) if (writer_rank == 0) then @@ -4599,7 +4599,7 @@ subroutine MAPL_NCIOParseTimeUnits ( TimeUnits, year, month, day, hour, min, sec end subroutine MAPL_NCIOParseTimeUnits ! WJ notes: To avoid changing gcm_run.j script, insert "_split_x_", not append - function get_fname_by_face(fname, rank) result(name) + function get_fname_by_rank(fname, rank) result(name) character(len=:), allocatable :: name character(len=*), intent(in) :: fname integer, intent(in) :: rank @@ -4607,7 +4607,7 @@ function get_fname_by_face(fname, rank) result(name) name = trim(fname)//"_"//i_to_string(rank) - end function get_fname_by_face + end function get_fname_by_rank function check_flip(metadata,rc) result(flip) type(FileMetadata), intent(inout) :: metadata diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 1a70fa2d1c59..9b1e529b3423 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -5996,7 +5996,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) if (split_restart) then FileExists = .true. do i = 0,num_files-1 - fname_by_reader = get_fname_by_face(trim(fname), i) + fname_by_reader = get_fname_by_rank(trim(fname), i) inquire(FILE = trim(fname_by_reader), EXIST=fexist) FileExists = FileExists .and. fexist enddo @@ -6225,7 +6225,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) !app_factory => get_factory(MPL%GRID%ESMFGRID) !! at this point, arrdes%read_restart_by_face is not initialized !! pick the first face - !fname_by_face = get_fname_by_face(trim(fname), 1) + !fname_by_face = get_fname_by_rank(trim(fname), 1) !inquire(FILE = trim(fname_by_face), EXIST=fexist) !if(fexist) then !allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) From dae6a49ea6455523ea56b5b572d62c16aae7c84c Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:09:31 -0400 Subject: [PATCH 009/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 533c24e20db1..3a4378d7c960 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -629,8 +629,7 @@ subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) ny = size(arrdes%j1) _ASSERT(num_writers < ny,'num writers must be less than NY') _ASSERT(mod(ny,num_writers)==0,'num writerss must evenly divide NY') - call mpi_comm_rank(full_comm,myid, status) - _VERIFY(status) + call mpi_comm_rank(full_comm,myid, _IERROR) color = arrdes%NX0 call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, status) color = arrdes%NY0 From 9593599e777d16bc56e2ef81a5ea8d6906d1e9b7 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:09:45 -0400 Subject: [PATCH 010/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 3a4378d7c960..d751fe318917 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -666,8 +666,7 @@ subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) _ASSERT(num_readers < ny,'num readers must be less than NY') _ASSERT(mod(ny,num_readers)==0,'num readers must evenly divide NY') - call mpi_comm_rank(full_comm,myid, status) - _VERIFY(status) + call mpi_comm_rank(full_comm,myid, _IERROR) color = arrdes%NX0 call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, status) color = arrdes%NY0 From a4b672d6841b976b7e4cb3ec428074e9357ad044 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:09:58 -0400 Subject: [PATCH 011/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index d751fe318917..791bbe2cfb0a 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -631,7 +631,7 @@ subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) _ASSERT(mod(ny,num_writers)==0,'num writerss must evenly divide NY') call mpi_comm_rank(full_comm,myid, _IERROR) color = arrdes%NX0 - call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, status) + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, _IERROR) color = arrdes%NY0 call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, status) ny_by_writers = ny/num_writers From dd95da3104640755310fe36677660715b682e25b Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:10:06 -0400 Subject: [PATCH 012/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 791bbe2cfb0a..984cd7481b92 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -645,7 +645,7 @@ subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) arrdes%IOgathercomm = arrdes%Xcomm else j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_writers) - call MPI_COMM_SPLIT(full_comm, j, myid, arrdes%IOgathercomm, status) + call MPI_COMM_SPLIT(full_comm, j, myid, arrdes%IOgathercomm, _IERROR) endif From 67c807daac9b71e21ca58c4692d91d6ae3b2b7e3 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:10:17 -0400 Subject: [PATCH 013/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 984cd7481b92..b46fe3218b69 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -677,7 +677,7 @@ subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) else color = MPI_UNDEFINED endif - call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%readers_comm, status) + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%readers_comm, _IERROR) if (num_readers==ny) then arrdes%IOscattercomm = arrdes%Xcomm else From 23c683647fdaefac92d780a17827a9e6eece3f8a Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:10:37 -0400 Subject: [PATCH 014/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index b46fe3218b69..e701b41a5a2f 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -668,7 +668,7 @@ subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) call mpi_comm_rank(full_comm,myid, _IERROR) color = arrdes%NX0 - call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, status) + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, _IERROR) color = arrdes%NY0 call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, status) ny_by_readers = ny/num_readers From 7ec5ac383a23c81543941105a86f7793e0156a49 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:11:06 -0400 Subject: [PATCH 015/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index e701b41a5a2f..50aef93f16e1 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -682,7 +682,7 @@ subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) arrdes%IOscattercomm = arrdes%Xcomm else j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_readers) - call MPI_COMM_SPLIT(full_comm, j, MYID, arrdes%IOscattercomm, status) + call MPI_COMM_SPLIT(full_comm, j, MYID, arrdes%IOscattercomm, _IERROR) endif _RETURN(_SUCCESS) From ff9d80e5d2bccac59ed32e4e0ea728621476ae63 Mon Sep 17 00:00:00 2001 From: Ben Auer Date: Fri, 29 Sep 2023 11:11:14 -0400 Subject: [PATCH 016/141] Update base/FileIOShared.F90 Co-authored-by: Tom Clune --- base/FileIOShared.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 50aef93f16e1..862822a0ee17 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -670,7 +670,7 @@ subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) color = arrdes%NX0 call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, _IERROR) color = arrdes%NY0 - call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, status) + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, _IERROR) ny_by_readers = ny/num_readers if (mod(myid,nx*ny/num_readers) == 0) then color = 0 From 3f9c5ee60815df5e5fce835afd162e7d37bb31f8 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 29 Sep 2023 12:07:30 -0400 Subject: [PATCH 017/141] cleanup error handling in FileIOShared.F90 --- base/FileIOShared.F90 | 109 ++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 69 deletions(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 862822a0ee17..8e252b221b41 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -295,13 +295,11 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) type(ESMF_VM) :: vm logical :: amIRoot - call ESMF_GridGet(grid, dimCount=gridRank, distGrid=distGrid, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid, dimCount=gridRank, distGrid=distGrid, _RC) _ASSERT(gridRank == 1, 'gridRank must be 1') call MAPL_GridGet(grid, globalCellCountPerDim=gcount, & - localCellCountPerDim=lcount, RC=STATUS) - _VERIFY(STATUS) + localCellCountPerDim=lcount, _RC) gsize = gcount(1) lsize = lcount(1) @@ -309,50 +307,37 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) call ESMF_DistGridGet(distgrid, localDe=0, elementCount=n, rc=status) _ASSERT(lsize == n, ' inconsistent lsize') - allocate(tileIndex(lsize), stat=status) - _VERIFY(STATUS) + allocate(tileIndex(lsize), _STAT) - call ESMF_DistGridGet(distgrid, localDe=0, seqIndexList=tileIndex, rc=status) - _VERIFY(STATUS) + call ESMF_DistGridGet(distgrid, localDe=0, seqIndexList=tileIndex, _RC) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - _VERIFY(STATUS) - call ESMF_DELayoutGet(layout, vm=vm, rc=status) - _VERIFY(STATUS) - call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status) - _VERIFY(STATUS) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, vm=vm, _RC) + call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, _RC) amIRoot = MAPL_AM_I_Root(vm) - call ESMF_VmBarrier(vm, rc=status) - _VERIFY(STATUS) + call ESMF_VmBarrier(vm, _RC) if (.not. MAPL_ShmInitialized) then - allocate(mask(gsize), stat=status) - _VERIFY(STATUS) + allocate(mask(gsize), _STAT) else - call MAPL_AllocNodeArray(mask,(/gsize/),rc=STATUS) + call MAPL_AllocNodeArray(mask,(/gsize/),rc=status) _VERIFY(STATUS) end if - allocate (AL(gridRank,0:nDEs-1), stat=status) - _VERIFY(STATUS) - allocate (AU(gridRank,0:nDEs-1), stat=status) - _VERIFY(STATUS) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPL_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) - _VERIFY(STATUS) + minIndex=AL, maxIndex=AU, _RC) - allocate (recvcounts(0:nDEs-1), displs(0:nDEs), stat=status) - _VERIFY(STATUS) + allocate (recvcounts(0:nDEs-1), displs(0:nDEs), _STAT) if (.not. MAPL_ShmInitialized .or. amIRoot) then - allocate(VAR(0:gsize-1), stat=status) - _VERIFY(STATUS) + allocate(VAR(0:gsize-1), _STAT) else - allocate(VAR(0), stat=status) - _VERIFY(STATUS) + allocate(VAR(0), _STAT) end if displs(0) = 0 @@ -381,19 +366,16 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) endif do II=I1,IN mmax=var(II) - call MAPL_CommsAllReduceMax(vm, mmax, var(II), 1, rc=status) - _VERIFY(STATUS) + call MAPL_CommsAllReduceMax(vm, mmax, var(II), 1, _RC) enddo end do #else if (MAPL_ShmInitialized) then call MAPL_CommsGatherV(layout, tileindex, sendcount, & - var, recvcounts, displs, MAPL_Root, status) - _VERIFY(STATUS) + var, recvcounts, displs, MAPL_Root, _RC) else call MAPL_CommsAllGatherV(layout, tileindex, sendcount, & - var, recvcounts, displs, status) - _VERIFY(STATUS) + var, recvcounts, displs, _RC) endif #endif @@ -413,11 +395,9 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) deallocate(tileIndex) ! mask is deallocated in the caller routine - call MAPL_BroadcastToNodes(MASK, N=gsize, ROOT=MAPL_Root, rc=status) - _VERIFY(STATUS) + call MAPL_BroadcastToNodes(MASK, N=gsize, ROOT=MAPL_Root, _RC) - call MAPL_SyncSharedMemory(rc=status) - _VERIFY(STATUS) + call MAPL_SyncSharedMemory(_RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_TileMaskGet @@ -446,10 +426,8 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers integer :: status - call MPI_Comm_Rank(comm,myid,status) - _VERIFY(STATUS) - call MPI_COMM_Size(comm,npes,status) - _VERIFY(STATUS) + call MPI_Comm_Rank(comm,myid,_IERROR) + call MPI_COMM_Size(comm,npes,_IERROR) allocate(iminw(npes),imaxw(npes),jminw(npes),jmaxw(npes),stat=status) iminw=-1 @@ -461,9 +439,13 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers jminw(myid+1)=js jmaxw(myid+1)=je call MPI_AllReduce(MPI_IN_PLACE,iminw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MPI_AllReduce(MPI_IN_PLACE,imaxw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MPI_AllReduce(MPI_IN_PLACE,jminw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MPI_AllReduce(MPI_IN_PLACE,jmaxw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MAPL_Sort(iminw) call MAPL_Sort(imaxw) @@ -502,11 +484,9 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers NX0 = mod(myid,nx) + 1 NY0 = myid/nx + 1 color = nx0 - call MPI_Comm_Split(comm,color,myid,ycomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,color,myid,ycomm,_IERROR) color = ny0 - call MPI_Comm_Split(comm,color,myid,xcomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,color,myid,xcomm,_IERROR) ! reader communicators if (num_readers > ny .or. mod(ny,num_readers) /= 0) then _RETURN(ESMF_FAILURE) @@ -517,14 +497,12 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers else color = MPI_UNDEFINED end if - call MPI_COMM_SPLIT(comm,color,myid,readers_comm,status) - _VERIFY(STATUS) + call MPI_COMM_SPLIT(comm,color,myid,readers_comm,_IERROR) if (num_readers==ny) then IOscattercomm = xcomm else j = ny0 - mod(ny0-1,ny_by_readers) - call MPI_Comm_Split(comm,j,myid,IOScattercomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,j,myid,IOScattercomm,_IERROR) endif ! writer communicators if (num_writers > ny .or. mod(ny,num_writers) /= 0) then @@ -536,14 +514,12 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers else color = MPI_UNDEFINED end if - call MPI_COMM_SPLIT(comm,color,myid,writers_comm,status) - _VERIFY(STATUS) + call MPI_COMM_SPLIT(comm,color,myid,writers_comm,_IERROR) if (num_writers==ny) then IOgathercomm = xcomm else j = ny0 - mod(ny0-1,ny_by_writers) - call MPI_Comm_Split(comm,j,myid,IOgathercomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,j,myid,IOgathercomm,_IERROR) endif ArrDes%im_world=im_world @@ -556,20 +532,15 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers ArrDes%iogathercomm = iogathercomm ArrDes%xcomm = xcomm ArrDes%ycomm = ycomm - call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,status) - _VERIFY(status) + call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,_IERROR) - allocate(arrdes%i1(size(i1)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%i1(size(i1)),_STAT) arrdes%i1=i1 - allocate(arrdes%in(size(in)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%in(size(in)),_STAT) arrdes%in=in - allocate(arrdes%j1(size(j1)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%j1(size(j1)),_STAT) arrdes%j1=j1 - allocate(arrdes%jn(size(jn)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%jn(size(jn)),_STAT) arrdes%jn=jn ArrDes%NX0 = NY0 @@ -633,14 +604,14 @@ subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) color = arrdes%NX0 call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, _IERROR) color = arrdes%NY0 - call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, status) + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, _IERROR) ny_by_writers = ny/num_writers if (mod(myid,nx*ny/num_writers) == 0) then color = 0 else color = MPI_UNDEFINED endif - call MPI_COMM_SPLIT(full_comm, color, myid, arrdes%writers_comm, status) + call MPI_COMM_SPLIT(full_comm, color, myid, arrdes%writers_comm, _IERROR) if (num_writers==ny) then arrdes%IOgathercomm = arrdes%Xcomm else From e81fa85b58a7ee75de75bb68b8edcb2e8907eaca Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 29 Sep 2023 14:59:15 -0400 Subject: [PATCH 018/141] restore check that grids match --- base/MAPL_GridManager.F90 | 8 +++--- base/NCIO.F90 | 4 +-- generic/MAPL_Generic.F90 | 56 +++++++++++++++++++-------------------- 3 files changed, 34 insertions(+), 34 deletions(-) diff --git a/base/MAPL_GridManager.F90 b/base/MAPL_GridManager.F90 index eb2bd07b782b..3827daab0d0d 100644 --- a/base/MAPL_GridManager.F90 +++ b/base/MAPL_GridManager.F90 @@ -476,7 +476,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, logical :: hasLongitude = .FALSE. logical :: hasLat = .FALSE. logical :: hasLatitude = .FALSE. - logical :: splitByface = .FALSE. + logical :: SplitCubedSphere = .FALSE. _UNUSED_DUMMY(unused) @@ -492,7 +492,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, call file_formatter%close(rc=status) _VERIFY(status) - splitByface = file_metadata%has_attribute("Cubed_Sphere_Face_Index") + SplitCubedSphere = file_metadata%has_attribute("Split_Cubed_Sphere") im = 0 hasXdim = file_metadata%has_dimension('Xdim') @@ -528,7 +528,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, if (status == _SUCCESS) then jm = file_metadata%get_dimension('Ydim',rc=status) _VERIFY(status) - if (jm == 6*im .or. splitByface) then + if (jm == 6*im .or. SplitCubedSphere) then allocate(factory, source=this%make_clone('Cubed-Sphere')) else if (file_metadata%has_dimension('nf')) then @@ -550,7 +550,7 @@ function make_factory_from_file(this, file_name, unused, force_file_coordinates, end if end if - if (jm == 6*im .or. splitByface) then ! old-format cubed-sphere + if (jm == 6*im .or. SplitCubedSphere) then ! old-format cubed-sphere allocate(factory, source=this%make_clone('Cubed-Sphere')) !!$ elseif (...) then ! something that is true for tripolar? !!$ factory = this%make_clone('tripolar') diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 886b586ac8c0..ed0d0c21f47b 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -2768,7 +2768,7 @@ function compare_grid_file(metadata,grid,rc) result(match) _VERIFY(status) file_lon_size = metadata%get_dimension("lon") file_lat_size = metadata%get_dimension("lat") - !if (metadata%has_attribute("Cubed_Sphere_Face_Index")) file_lat_size = file_lat_size*6 + if (metadata%has_attribute("Split_Cubed_Sphere")) file_lat_size = file_lat_size*6 file_lev_size = metadata%get_dimension("lev") file_tile_size = metadata%get_dimension("tile") @@ -3864,7 +3864,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) if (writer_rank == 0) then call create_control_file(filename,arrdes%im_world,arrdes%num_writers,rc) end if - !call cf%add_attribute("Cubed_Sphere_Face_Index", arrdes%face_index, _RC) + call cf%add_attribute("Split_Cubed_Sphere", writer_rank, _RC) else call formatter%create_par(trim(filename),comm=arrdes%writers_comm,info=info,rc=status) _VERIFY(status) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 9b1e529b3423..ec558fe4667e 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -6149,7 +6149,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_AttributeGet(MPL%GRID%ESMFGRID,'GridType',value=grid_type,rc=status) _VERIFY(status) end if - !_ASSERT(grid_is_consistent(grid_type, fname), "grid in the file is different from app's grid") + _ASSERT(grid_is_consistent(grid_type, fname), "grid in the file is different from app's grid") call ArrDescrSetNCPar(arrdes,MPL,num_readers=mpl%grid%num_readers,RC=status) _VERIFY(status) end if PNC4_TILE @@ -6208,33 +6208,33 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _RETURN(ESMF_SUCCESS) - !contains - !function grid_is_consistent(grid_type, fname) result( consistent) - !logical :: consistent - !character(*), intent(in) :: grid_type - !character(*), intent(in) :: fname - !!note this only works for geos cubed-sphere restarts currently because of - !!possible insufficent metadata in the other restarts to support the other grid factories - !class(AbstractGridFactory), pointer :: app_factory - !class (AbstractGridFactory), allocatable :: file_factory - !character(len=:), allocatable :: fname_by_face - !logical :: fexist - - !consistent = .True. - !if (trim(grid_type) == 'Cubed-Sphere') then - !app_factory => get_factory(MPL%GRID%ESMFGRID) - !! at this point, arrdes%read_restart_by_face is not initialized - !! pick the first face - !fname_by_face = get_fname_by_rank(trim(fname), 1) - !inquire(FILE = trim(fname_by_face), EXIST=fexist) - !if(fexist) then - !allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) - !else - !allocate(file_factory,source=grid_manager%make_factory(trim(fname))) - !endif - !consistent = file_factory%physical_params_are_equal(app_factory) - !end if - !end function + contains + function grid_is_consistent(grid_type, fname) result( consistent) + logical :: consistent + character(*), intent(in) :: grid_type + character(*), intent(in) :: fname + !note this only works for geos cubed-sphere restarts currently because of + !possible insufficent metadata in the other restarts to support the other grid factories + class(AbstractGridFactory), pointer :: app_factory + class (AbstractGridFactory), allocatable :: file_factory + character(len=:), allocatable :: fname_by_face + logical :: fexist + + consistent = .True. + if (trim(grid_type) == 'Cubed-Sphere') then + app_factory => get_factory(MPL%GRID%ESMFGRID) + ! at this point, arrdes%read_restart_by_face is not initialized + ! pick the first face + fname_by_face = get_fname_by_rank(trim(fname), 1) + inquire(FILE = trim(fname_by_face), EXIST=fexist) + if(fexist) then + allocate(file_factory,source=grid_manager%make_factory(fname_by_face)) + else + allocate(file_factory,source=grid_manager%make_factory(trim(fname))) + endif + consistent = file_factory%physical_params_are_equal(app_factory) + end if + end function end subroutine MAPL_ESMFStateReadFromFile From 18c70e5c2acd4cdaf6832e513b54132bcdb9ce30 Mon Sep 17 00:00:00 2001 From: Atanas Trayanov Date: Fri, 24 Nov 2023 14:13:19 -0500 Subject: [PATCH 019/141] Hand merge with the difference beween the last two commits on feature/atrayano/updates-for-milan brancsh (as of Nov-24-2023) with develop. This is to eliminate unnnecessary allocation during checkpoint writes and a different algorith for the tile restarts --- base/BinIO.F90 | 189 +--------------------- base/FileIOShared.F90 | 364 ++++++++++++++++++++++++++++++++++-------- base/NCIO.F90 | 63 +++++++- 3 files changed, 355 insertions(+), 261 deletions(-) diff --git a/base/BinIO.F90 b/base/BinIO.F90 index 55335c89fce1..74d2ff787f7e 100644 --- a/base/BinIO.F90 +++ b/base/BinIO.F90 @@ -20,6 +20,7 @@ module BinIOMod use FileIOSharedMod, only: STD_OUT_UNIT_NUMBER, LAST_UNIT, TAKEN, MTAKEN, mname use FileIOSharedMod, only: r4_2, r4_1, r8_2, r8_1, i4_1 use FileIOSharedMod, only: MEM_UNITS, munit, REC + use FileIOSharedMod, only: ArrayScatterShm use ESMF use MAPL_BaseMod use MAPL_SortMod @@ -72,10 +73,6 @@ module BinIOMod module procedure READ_PARALLEL_R8_2 end interface - interface ArrayScatterShm - module procedure ArrayScatterShmR4D1 - end interface ArrayScatterShm - interface MAPL_MemFileInquire module procedure InqFileMem end interface @@ -3936,190 +3933,6 @@ subroutine MAPL_Rewind(UNIT, LAYOUT, RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_Rewind - subroutine ArrayScatterShmR4D1(local_array, global_array, grid, mask, rc) - -! Mask is really a permutation on the first dimension - - real, intent( OUT) :: local_array(:) -! TYPE_(kind=EKIND_), target, intent(IN ) :: global_array DIMENSIONS_ - real, target :: global_array(:) - type (ESMF_Grid) :: grid - integer, optional, intent(IN ) :: mask(:) - integer, optional, intent( OUT) :: rc - -! Local variables - - integer :: status - - real, pointer :: myglob(:) => null() - real, pointer :: VAR(:) - type (ESMF_DistGrid) :: distGrid - type(ESMF_DELayout) :: LAYOUT - type (ESMF_VM) :: vm - integer, allocatable :: AL(:,:) - integer, allocatable :: AU(:,:) - integer, dimension(:), allocatable :: SENDCOUNTS, DISPLS - integer :: KK - integer :: nDEs - integer :: recvcount - integer :: I, K, II, deId - integer :: gridRank - integer :: LX - integer :: srcPE - integer :: ISZ - logical :: alloc_var - logical :: use_shmem - -! Works only on 1D and 2D arrays -! Note: for tile variables the gridRank is 1 -! and the case RANK_=2 needs additional attention - -! use_shmem controls communication (bcastToNodes+local copy vs scatterv) - use_shmem = .true. - - ! temporary Shmem restricted only to 1d and tile vars - if (.not.present(mask)) use_shmem = .false. - -! Optional change of source PE. Default=MAPL_Root - - srcPE = MAPL_Root - -! Initialize - alloc_var = .true. - -! Get grid and layout information - - call ESMF_GridGet (GRID, dimCount=gridRank, rc=STATUS);_VERIFY(STATUS) - call ESMF_GridGet (GRID, distGrid=distGrid, rc=STATUS);_VERIFY(STATUS) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS);_VERIFY(STATUS) - call ESMF_DELayoutGet(layout, vm=vm, rc=status);_VERIFY(STATUS) - call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status);_VERIFY(STATUS) - - if (use_shmem) then - srcPE = deId - end if - - allocate (AL(gridRank,0:nDEs-1), stat=status) - _VERIFY(STATUS) - allocate (AU(gridRank,0:nDEs-1), stat=status) - _VERIFY(STATUS) - allocate (sendcounts(0:nDEs-1), stat=status) - _VERIFY(STATUS) - call MAPL_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) - _VERIFY(STATUS) - - ISZ = size(GLOBAL_ARRAY,1) - - if (use_shmem) then - call MAPL_SyncSharedMemory(rc=STATUS) - _VERIFY(STATUS) - call MAPL_BroadcastToNodes(global_array, N=ISZ, ROOT=MAPL_Root, rc=status) - _VERIFY(STATUS) - call MAPL_SyncSharedMemory(rc=STATUS) - _VERIFY(STATUS) - end if - -! Compute count to be sent to each PE - - if(present(mask)) then - sendcounts = 0 - do II = 1,ISZ - sendcounts(mask(ii)) = sendcounts(mask(ii)) + 1 - enddo - else - do I = 0,nDEs-1 - LX = AU(1,I) - AL(1,I) + 1 - sendcounts(I) = LX - end do - end if - -! Count I will recieve - - recvcount = sendcounts(deId) - -! Put VAR together at the srcPE - - if (deId == srcPE) then - - allocate(DISPLS(0:nDEs ), stat=status) - _VERIFY(STATUS) - -! Compute displacements into the VAR vector - - displs(0) = 0 - do I = 1,nDEs - displs(I) = displs(I-1) + sendcounts(I-1) - end do - - myglob => global_array - -! Fill the VAR vector - - if (present(mask)) then - allocate(VAR(displs(deId):displs(deId+1)-1), stat=status) - _VERIFY(STATUS) - KK = DISPLS(deId) - - do I=1,ISZ - K = MASK(I) - if(K == deId) then - II = KK - VAR(II) = MYGLOB(I) - KK = KK + 1 - end if - end do - - else - - var => myglob - alloc_var = .false. - - endif ! present(mask) - - else - allocate(var(0:1), stat=status) - _VERIFY(STATUS) - allocate(DISPLS(0:nDEs), stat=status) - _VERIFY(STATUS) - end if ! I am srcPEa - - -! Do the communications - if (use_shmem) then - ! copy my piece from var (var is local but was filled from shared array) - call MAPL_SyncSharedMemory(rc=STATUS) - _VERIFY(STATUS) - local_array = var(displs(deId):displs(deId+1)-1) - call MAPL_SyncSharedMemory(rc=STATUS) - _VERIFY(STATUS) - else - call MAPL_CommsScatterV(layout, var, sendcounts, displs, & - local_array, recvcount, srcPE, status) - _VERIFY(STATUS) - end if - -! Clean-up - - deallocate(displs, stat=status) - _VERIFY(STATUS) - if(alloc_var) then - deallocate(VAR, stat=status) - _VERIFY(STATUS) - end if - - deallocate(sendcounts, stat=status) - _VERIFY(STATUS) - deallocate(AU, stat=status) - _VERIFY(STATUS) - deallocate(AL, stat=status) - _VERIFY(STATUS) - -! All done - - _RETURN(ESMF_SUCCESS) - end subroutine ArrayScatterShmR4D1 - INTEGER FUNCTION GETFILE( NAME, DO_OPEN, FORM, ALL_PES, & BLOCKSIZE, NUMBUFFERS, RC ) IMPLICIT NONE diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 67f63078799c..8697efdbc4d5 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -34,6 +34,7 @@ module FileIOSharedMod ! public interfaces public WRITE_PARALLEL + public ArrayScatterShm ! public subroutines public MAPL_TileMaskGet @@ -118,6 +119,10 @@ module FileIOSharedMod module procedure WRITE_PARALLEL_STRING_0 end interface + interface ArrayScatterShm + module procedure ArrayScatterShmR4D1 + end interface ArrayScatterShm + contains !--WRITES ------------------ @@ -295,13 +300,11 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) type(ESMF_VM) :: vm logical :: amIRoot - call ESMF_GridGet(grid, dimCount=gridRank, distGrid=distGrid, rc=status) - _VERIFY(STATUS) + call ESMF_GridGet(grid, dimCount=gridRank, distGrid=distGrid, _RC) _ASSERT(gridRank == 1, 'gridRank must be 1') call MAPL_GridGet(grid, globalCellCountPerDim=gcount, & - localCellCountPerDim=lcount, RC=STATUS) - _VERIFY(STATUS) + localCellCountPerDim=lcount, _RC) gsize = gcount(1) lsize = lcount(1) @@ -309,50 +312,36 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) call ESMF_DistGridGet(distgrid, localDe=0, elementCount=n, rc=status) _ASSERT(lsize == n, ' inconsistent lsize') - allocate(tileIndex(lsize), stat=status) - _VERIFY(STATUS) + allocate(tileIndex(lsize), _STAT) - call ESMF_DistGridGet(distgrid, localDe=0, seqIndexList=tileIndex, rc=status) - _VERIFY(STATUS) + call ESMF_DistGridGet(distgrid, localDe=0, seqIndexList=tileIndex, _RC) - call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) - _VERIFY(STATUS) - call ESMF_DELayoutGet(layout, vm=vm, rc=status) - _VERIFY(STATUS) - call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status) - _VERIFY(STATUS) + call ESMF_DistGridGet(distGRID, delayout=layout, _RC) + call ESMF_DELayoutGet(layout, vm=vm, _RC) + call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, _RC) amIRoot = MAPL_AM_I_Root(vm) - call ESMF_VmBarrier(vm, rc=status) - _VERIFY(STATUS) + call ESMF_VmBarrier(vm, _RC) if (.not. MAPL_ShmInitialized) then - allocate(mask(gsize), stat=status) - _VERIFY(STATUS) + allocate(mask(gsize), _STAT) else - call MAPL_AllocNodeArray(mask,(/gsize/),rc=STATUS) - _VERIFY(STATUS) + call MAPL_AllocNodeArray(mask,(/gsize/),_RC) end if - allocate (AL(gridRank,0:nDEs-1), stat=status) - _VERIFY(STATUS) - allocate (AU(gridRank,0:nDEs-1), stat=status) - _VERIFY(STATUS) + allocate (AL(gridRank,0:nDEs-1), _STAT) + allocate (AU(gridRank,0:nDEs-1), _STAT) call MAPL_DistGridGet(distgrid, & - minIndex=AL, maxIndex=AU, rc=status) - _VERIFY(STATUS) + minIndex=AL, maxIndex=AU, _RC) - allocate (recvcounts(0:nDEs-1), displs(0:nDEs), stat=status) - _VERIFY(STATUS) + allocate (recvcounts(0:nDEs-1), displs(0:nDEs), _STAT) if (.not. MAPL_ShmInitialized .or. amIRoot) then - allocate(VAR(0:gsize-1), stat=status) - _VERIFY(STATUS) + allocate(VAR(0:gsize-1), _STAT) else - allocate(VAR(0), stat=status) - _VERIFY(STATUS) + allocate(VAR(0), _STAT) end if displs(0) = 0 @@ -381,19 +370,16 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) endif do II=I1,IN mmax=var(II) - call MAPL_CommsAllReduceMax(vm, mmax, var(II), 1, rc=status) - _VERIFY(STATUS) + call MAPL_CommsAllReduceMax(vm, mmax, var(II), 1, _RC) enddo end do #else if (MAPL_ShmInitialized) then call MAPL_CommsGatherV(layout, tileindex, sendcount, & - var, recvcounts, displs, MAPL_Root, status) - _VERIFY(STATUS) + var, recvcounts, displs, MAPL_Root, _RC) else call MAPL_CommsAllGatherV(layout, tileindex, sendcount, & - var, recvcounts, displs, status) - _VERIFY(STATUS) + var, recvcounts, displs, _RC) endif #endif @@ -413,11 +399,9 @@ subroutine MAPL_TileMaskGet(grid, mask, rc) deallocate(tileIndex) ! mask is deallocated in the caller routine - call MAPL_BroadcastToNodes(MASK, N=gsize, ROOT=MAPL_Root, rc=status) - _VERIFY(STATUS) + call MAPL_BroadcastToNodes(MASK, N=gsize, ROOT=MAPL_Root, _RC) - call MAPL_SyncSharedMemory(rc=status) - _VERIFY(STATUS) + call MAPL_SyncSharedMemory(_RC) _RETURN(ESMF_SUCCESS) end subroutine MAPL_TileMaskGet @@ -446,10 +430,8 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers integer :: status - call MPI_Comm_Rank(comm,myid,status) - _VERIFY(STATUS) - call MPI_COMM_Size(comm,npes,status) - _VERIFY(STATUS) + call MPI_Comm_Rank(comm,myid,_IERROR) + call MPI_COMM_Size(comm,npes,_IERROR) allocate(iminw(npes),imaxw(npes),jminw(npes),jmaxw(npes),stat=status) iminw=-1 @@ -461,9 +443,13 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers jminw(myid+1)=js jmaxw(myid+1)=je call MPI_AllReduce(MPI_IN_PLACE,iminw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MPI_AllReduce(MPI_IN_PLACE,imaxw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MPI_AllReduce(MPI_IN_PLACE,jminw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MPI_AllReduce(MPI_IN_PLACE,jmaxw,npes,MPI_INTEGER,MPI_MAX,comm,status) + _VERIFY(STATUS) call MAPL_Sort(iminw) call MAPL_Sort(imaxw) @@ -502,11 +488,9 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers NX0 = mod(myid,nx) + 1 NY0 = myid/nx + 1 color = nx0 - call MPI_Comm_Split(comm,color,myid,ycomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,color,myid,ycomm,_IERROR) color = ny0 - call MPI_Comm_Split(comm,color,myid,xcomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,color,myid,xcomm,_IERROR) ! reader communicators if (num_readers > ny .or. mod(ny,num_readers) /= 0) then _RETURN(ESMF_FAILURE) @@ -517,14 +501,12 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers else color = MPI_UNDEFINED end if - call MPI_COMM_SPLIT(comm,color,myid,readers_comm,status) - _VERIFY(STATUS) + call MPI_COMM_SPLIT(comm,color,myid,readers_comm,_IERROR) if (num_readers==ny) then IOscattercomm = xcomm else j = ny0 - mod(ny0-1,ny_by_readers) - call MPI_Comm_Split(comm,j,myid,IOScattercomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,j,myid,IOScattercomm,_IERROR) endif ! writer communicators if (num_writers > ny .or. mod(ny,num_writers) /= 0) then @@ -536,14 +518,12 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers else color = MPI_UNDEFINED end if - call MPI_COMM_SPLIT(comm,color,myid,writers_comm,status) - _VERIFY(STATUS) + call MPI_COMM_SPLIT(comm,color,myid,writers_comm,_IERROR) if (num_writers==ny) then IOgathercomm = xcomm else j = ny0 - mod(ny0-1,ny_by_writers) - call MPI_Comm_Split(comm,j,myid,IOgathercomm,status) - _VERIFY(STATUS) + call MPI_Comm_Split(comm,j,myid,IOgathercomm,_IERROR) endif ArrDes%im_world=im_world @@ -557,17 +537,13 @@ subroutine ArrDescrInit(ArrDes,comm,im_world,jm_world,lm_world,nx,ny,num_readers ArrDes%xcomm = xcomm ArrDes%ycomm = ycomm - allocate(arrdes%i1(size(i1)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%i1(size(i1)),_STAT) arrdes%i1=i1 - allocate(arrdes%in(size(in)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%in(size(in)),_STAT) arrdes%in=in - allocate(arrdes%j1(size(j1)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%j1(size(j1)),_STAT) arrdes%j1=j1 - allocate(arrdes%jn(size(jn)),stat=status) - _VERIFY(STATUS) + allocate(arrdes%jn(size(jn)),_STAT) arrdes%jn=jn ArrDes%NX0 = NY0 @@ -619,4 +595,260 @@ subroutine ArrDescrSet(ArrDes, offset, & end subroutine ArrDescrSet + subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) + type(ArrDescr), intent(inout) :: arrdes + integer, intent(in) :: full_comm + integer, intent(in) :: num_writers + integer, optional, intent(out) :: rc + + integer :: status, nx, ny, color, ny_by_writers, myid, j + + nx = size(arrdes%i1) + ny = size(arrdes%j1) + _ASSERT(num_writers < ny,'num writers must be less than NY') + _ASSERT(mod(ny,num_writers)==0,'num writerss must evenly divide NY') + call mpi_comm_rank(full_comm,myid, _IERROR) + color = arrdes%NX0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, _IERROR) + color = arrdes%NY0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, _IERROR) + ny_by_writers = ny/num_writers + if (mod(myid,nx*ny/num_writers) == 0) then + color = 0 + else + color = MPI_UNDEFINED + endif + call MPI_COMM_SPLIT(full_comm, color, myid, arrdes%writers_comm, _IERROR) + if (num_writers==ny) then + arrdes%IOgathercomm = arrdes%Xcomm + else + j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_writers) + call MPI_COMM_SPLIT(full_comm, j, myid, arrdes%IOgathercomm, _IERROR) + endif + + + _RETURN(_SUCCESS) + + end subroutine ArrDescrCreateWriterComm + + subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) + type(ArrDescr), intent(inout) :: arrdes + integer, intent(in) :: full_comm + integer, intent(in) :: num_readers + integer, optional, intent(out) :: rc + + integer :: status, nx, ny, color, ny_by_readers, myid, j + + nx = size(arrdes%i1) + ny = size(arrdes%j1) + _ASSERT(num_readers < ny,'num readers must be less than NY') + _ASSERT(mod(ny,num_readers)==0,'num readers must evenly divide NY') + + call mpi_comm_rank(full_comm,myid, _IERROR) + color = arrdes%NX0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Ycomm, _IERROR) + color = arrdes%NY0 + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%Xcomm, _IERROR) + ny_by_readers = ny/num_readers + if (mod(myid,nx*ny/num_readers) == 0) then + color = 0 + else + color = MPI_UNDEFINED + endif + call MPI_COMM_SPLIT(full_comm, color, MYID, arrdes%readers_comm, _IERROR) + if (num_readers==ny) then + arrdes%IOscattercomm = arrdes%Xcomm + else + j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_readers) + call MPI_COMM_SPLIT(full_comm, j, MYID, arrdes%IOscattercomm, _IERROR) + endif + + _RETURN(_SUCCESS) + + end subroutine ArrDescrCreateReaderComm + + subroutine ArrayScatterShmR4D1(local_array, global_array, grid, mask, rc) + +! Mask is really a permutation on the first dimension + + real, intent( OUT) :: local_array(:) +! TYPE_(kind=EKIND_), target, intent(IN ) :: global_array DIMENSIONS_ + real, target :: global_array(:) + type (ESMF_Grid) :: grid + integer, optional, intent(IN ) :: mask(:) + integer, optional, intent( OUT) :: rc + +! Local variables + + integer :: status + + real, pointer :: myglob(:) => null() + real, pointer :: VAR(:) + type (ESMF_DistGrid) :: distGrid + type(ESMF_DELayout) :: LAYOUT + type (ESMF_VM) :: vm + integer, allocatable :: AL(:,:) + integer, allocatable :: AU(:,:) + integer, dimension(:), allocatable :: SENDCOUNTS, DISPLS + integer :: KK + integer :: nDEs + integer :: recvcount + integer :: I, K, II, deId + integer :: gridRank + integer :: LX + integer :: srcPE + integer :: ISZ + logical :: alloc_var + logical :: use_shmem + +! Works only on 1D and 2D arrays +! Note: for tile variables the gridRank is 1 +! and the case RANK_=2 needs additional attention + +! use_shmem controls communication (bcastToNodes+local copy vs scatterv) + use_shmem = .true. + + ! temporary Shmem restricted only to 1d and tile vars + if (.not.present(mask)) use_shmem = .false. + +! Optional change of source PE. Default=MAPL_Root + + srcPE = MAPL_Root + +! Initialize + alloc_var = .true. + +! Get grid and layout information + + call ESMF_GridGet (GRID, dimCount=gridRank, rc=STATUS);_VERIFY(STATUS) + call ESMF_GridGet (GRID, distGrid=distGrid, rc=STATUS);_VERIFY(STATUS) + call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS);_VERIFY(STATUS) + call ESMF_DELayoutGet(layout, vm=vm, rc=status);_VERIFY(STATUS) + call ESMF_VmGet(vm, localPet=deId, petCount=nDEs, rc=status);_VERIFY(STATUS) + + if (use_shmem) then + srcPE = deId + end if + + allocate (AL(gridRank,0:nDEs-1), stat=status) + _VERIFY(STATUS) + allocate (AU(gridRank,0:nDEs-1), stat=status) + _VERIFY(STATUS) + allocate (sendcounts(0:nDEs-1), stat=status) + _VERIFY(STATUS) + call MAPL_DistGridGet(distgrid, & + minIndex=AL, maxIndex=AU, rc=status) + _VERIFY(STATUS) + + ISZ = size(GLOBAL_ARRAY,1) + + if (use_shmem) then + call MAPL_SyncSharedMemory(rc=STATUS) + _VERIFY(STATUS) + call MAPL_BroadcastToNodes(global_array, N=ISZ, ROOT=MAPL_Root, rc=status) + _VERIFY(STATUS) + call MAPL_SyncSharedMemory(rc=STATUS) + _VERIFY(STATUS) + end if + +! Compute count to be sent to each PE + + if(present(mask)) then + sendcounts = 0 + do II = 1,ISZ + sendcounts(mask(ii)) = sendcounts(mask(ii)) + 1 + enddo + else + do I = 0,nDEs-1 + LX = AU(1,I) - AL(1,I) + 1 + sendcounts(I) = LX + end do + end if + +! Count I will recieve + + recvcount = sendcounts(deId) + +! Put VAR together at the srcPE + + if (deId == srcPE) then + + allocate(DISPLS(0:nDEs ), stat=status) + _VERIFY(STATUS) + +! Compute displacements into the VAR vector + + displs(0) = 0 + do I = 1,nDEs + displs(I) = displs(I-1) + sendcounts(I-1) + end do + + myglob => global_array + +! Fill the VAR vector + + if (present(mask)) then + allocate(VAR(displs(deId):displs(deId+1)-1), stat=status) + _VERIFY(STATUS) + KK = DISPLS(deId) + + do I=1,ISZ + K = MASK(I) + if(K == deId) then + II = KK + VAR(II) = MYGLOB(I) + KK = KK + 1 + end if + end do + + else + + var => myglob + alloc_var = .false. + + endif ! present(mask) + + else + allocate(var(0:1), stat=status) + _VERIFY(STATUS) + allocate(DISPLS(0:nDEs), stat=status) + _VERIFY(STATUS) + end if ! I am srcPEa + + +! Do the communications + if (use_shmem) then + ! copy my piece from var (var is local but was filled from shared array) + call MAPL_SyncSharedMemory(rc=STATUS) + _VERIFY(STATUS) + local_array = var(displs(deId):displs(deId+1)-1) + call MAPL_SyncSharedMemory(rc=STATUS) + _VERIFY(STATUS) + else + call MAPL_CommsScatterV(layout, var, sendcounts, displs, & + local_array, recvcount, srcPE, status) + _VERIFY(STATUS) + end if + +! Clean-up + + deallocate(displs, stat=status) + _VERIFY(STATUS) + if(alloc_var) then + deallocate(VAR, stat=status) + _VERIFY(STATUS) + end if + + deallocate(sendcounts, stat=status) + _VERIFY(STATUS) + deallocate(AU, stat=status) + _VERIFY(STATUS) + deallocate(AL, stat=status) + _VERIFY(STATUS) + +! All done + + _RETURN(ESMF_SUCCESS) + end subroutine ArrayScatterShmR4D1 + end module FileIOSharedMod diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 90394334a0ba..b1b0a0d2823d 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -12,6 +12,7 @@ module NCIOMod use FileIOSharedMod, only: ArrDescr, ArrDescrSet, WRITE_PARALLEL, MAPL_TileMaskGet + use FileIOSharedMod, only: ArrayScatterShm use ESMF use MAPL_BaseMod use MAPL_CommsMod @@ -1198,13 +1199,11 @@ subroutine MAPL_VarWriteNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, of #endif if(arrdes%writers_comm /= MPI_COMM_NULL) then - allocate(GVAR(Rsize), stat=status) - _VERIFY(STATUS) + allocate(GVAR(Rsize), _STAT) + allocate(VAR(Rsize), msk(Rsize), _STAT) + else + allocate(VAR(0), msk(0), _STAT) end if - allocate(VAR(Rsize), stat=status) - _VERIFY(STATUS) - allocate(msk(Rsize), stat=status) - _VERIFY(STATUS) allocate (recvcounts(0:npes-1), stat=status) _VERIFY(STATUS) allocate (r2g(0:nwrts-1), stat=status) @@ -1758,6 +1757,7 @@ subroutine MAPL_VarReadNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, off ! Local variables real(kind=ESMF_KIND_R4), allocatable :: VAR(:) + real(kind=ESMF_KIND_R4), pointer :: VR(:)=>null() integer :: IM_WORLD integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R4_1d' @@ -1779,11 +1779,12 @@ subroutine MAPL_VarReadNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, off integer, allocatable :: activeranks(:) integer, allocatable :: activesendcounts(:) integer :: start(4), cnt(4) + logical :: amIRoot if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world - +#ifdef USE_MAPL_ORIGINAL_TILE_HANDLING call mpi_comm_size(arrdes%ioscattercomm,npes ,status) _VERIFY(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then @@ -1987,6 +1988,54 @@ subroutine MAPL_VarReadNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, off if(arrdes%readers_comm /= MPI_COMM_NULL) then deallocate(idx) end if +#else +!if USE_MAPL_ORIGINAL_TILE_HANDLING + + amIRoot = MAPL_am_i_root(layout) + if (.not. MAPL_ShmInitialized) then + if (amIRoot) then + allocate(VR(IM_WORLD), stat=status) + _VERIFY(STATUS) + else + allocate(VR(0), stat=status) + _VERIFY(STATUS) + end if + else + call MAPL_AllocNodeArray(vr,[IM_WORLD],_RC) + end if + + if (amIRoot) then + start(1) = 1 + start(2) = 1 + start(3) = 1 + if ( present(offset1) ) start(2) = offset1 + if ( present(offset2) ) start(3) = offset2 + start(4) = 1 + cnt(1) = im_world + cnt(2) = 1 + cnt(3) = 1 + cnt(4) = 1 + + call formatter%get_var(trim(name),vr,start=start,count=cnt,rc=status) + if(status /= NF90_NOERR) then + print*,'Error reading variable ',status + print*, NF90_STRERROR(status) + _VERIFY(STATUS) + endif + end if + + if (.not. MAPL_ShmInitialized) then + call ArrayScatter(A, VR, arrdes%grid, mask=mask, rc=status) + _VERIFY(STATUS) + + deallocate(VR) + else + call ArrayScatterShm(A, VR, arrdes%grid, mask=mask, rc=status) + _VERIFY(STATUS) + call MAPL_DeAllocNodeArray(VR,rc=STATUS) + _VERIFY(STATUS) + end if +#endif else From a9fda84df33f4d7ee6513bc1c3463d245d7c59b7 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 5 Dec 2023 11:01:37 -0500 Subject: [PATCH 020/141] beta test to explore dumping and then re-using regridding weights for ESMF --- Apps/Regrid_Util.F90 | 4 +- base/MAPL_EsmfRegridder.F90 | 229 ++++++++++++++++++++++-------------- base/MaplGrid.F90 | 27 ++++- 3 files changed, 168 insertions(+), 92 deletions(-) diff --git a/Apps/Regrid_Util.F90 b/Apps/Regrid_Util.F90 index 7a247d05c615..bc852cb071be 100644 --- a/Apps/Regrid_Util.F90 +++ b/Apps/Regrid_Util.F90 @@ -557,8 +557,8 @@ subroutine generate_report() call reporter%add_column(FormattedTextColumn('% Excl','(f6.2)', 6, PercentageColumn(ExclusiveColumn('MEAN')))) call reporter%add_column(FormattedTextColumn(' Max Excl)','(f9.6)', 9, ExclusiveColumn('MAX'))) call reporter%add_column(FormattedTextColumn(' Min Excl)','(f9.6)', 9, ExclusiveColumn('MIN'))) - call reporter%add_column(FormattedTextColumn('Max PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MAX_PE'))) - call reporter%add_column(FormattedTextColumn('Min PE)','(1x,i4.4,1x)', 6, ExclusiveColumn('MIN_PE'))) + call reporter%add_column(FormattedTextColumn('Max PE)','(1x,i5.5,1x)', 7, ExclusiveColumn('MAX_PE'))) + call reporter%add_column(FormattedTextColumn('Min PE)','(1x,i5.5,1x)', 7, ExclusiveColumn('MIN_PE'))) report_lines = reporter%generate_report(t_prof) if (mapl_am_I_root()) then write(*,'(a)')'Final profile' diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 581545b41c57..c5e26e3ee0a8 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -12,6 +12,8 @@ module MAPL_EsmfRegridderMod use MAPL_GridManagerMod use MAPL_BaseMod, only: MAPL_undef, MAPL_GridHasDE use MAPL_RegridderSpecRouteHandleMap + use MAPL_CommsMod + use MAPL_MAPLGrid implicit none private @@ -1436,6 +1438,8 @@ subroutine create_route_handle(this, kind, rc) logical :: global, isPresent type(RegridderSpecRouteHandleMap), pointer :: route_handles, transpose_route_handles type(ESMF_RouteHandle) :: route_handle, transpose_route_handle + character(len=ESMF_MAXPATHLEN) :: rh_file,rh_trans_file + logical :: rh_file_exists if (kind == ESMF_TYPEKIND_R4) then route_handles => route_handles_r4 @@ -1452,103 +1456,116 @@ subroutine create_route_handle(this, kind, rc) spec = this%get_spec() if (route_handles%count(spec) == 0) then ! new route_handle - src_field = ESMF_FieldCreate(spec%grid_in, typekind=kind, & - & indexflag=ESMF_INDEX_DELOCAL, staggerloc=ESMF_STAGGERLOC_CENTER, rc=status) - _VERIFY(status) + rh_file = generate_rh_name(spec%grid_in,spec%grid_out,_RC) + rh_trans_file = "transpose_"//rh_file + inquire(file=rh_file,exist=rh_file_exists) + if (rh_file_exists) then + if (mapl_am_I_root()) write(*,*)"bmaa reading RH file" + route_handle = ESMF_RouteHandleCreate(rh_file,_RC) + transpose_route_handle = ESMF_RouteHandleCreate(rh_trans_file,_RC) + call route_handles%insert(spec, route_handle) + call transpose_route_handles%insert(spec, transpose_route_handle) + else + src_field = ESMF_FieldCreate(spec%grid_in, typekind=kind, & + & indexflag=ESMF_INDEX_DELOCAL, staggerloc=ESMF_STAGGERLOC_CENTER, rc=status) + _VERIFY(status) - if (MAPL_GridHasDE(spec%grid_in)) then - if (kind == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(src_field, localDe=0, farrayPtr=src_dummy_r4, rc=status) - _VERIFY(status) - src_dummy_r4 = 0 - else if (kind == ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(src_field, localDe=0, farrayPtr=src_dummy_r8, rc=status) - _VERIFY(status) - src_dummy_r8 = 0 + if (MAPL_GridHasDE(spec%grid_in)) then + if (kind == ESMF_TYPEKIND_R4) then + call ESMF_FieldGet(src_field, localDe=0, farrayPtr=src_dummy_r4, rc=status) + _VERIFY(status) + src_dummy_r4 = 0 + else if (kind == ESMF_TYPEKIND_R8) then + call ESMF_FieldGet(src_field, localDe=0, farrayPtr=src_dummy_r8, rc=status) + _VERIFY(status) + src_dummy_r8 = 0 + end if end if - end if - dst_field = ESMF_FieldCreate(spec%grid_out, typekind=kind, & - & indexflag=ESMF_INDEX_DELOCAL, staggerloc=ESMF_STAGGERLOC_CENTER, rc=status) - _VERIFY(status) - if (MAPL_GridHasDE(spec%grid_out)) then - if (kind == ESMF_TYPEKIND_R4) then - call ESMF_FieldGet(dst_field, localDe=0, farrayPtr=dst_dummy_r4, rc=status) - _VERIFY(status) - dst_dummy_r4 = 0 - else if (kind == ESMF_TYPEKIND_R8) then - call ESMF_FieldGet(dst_field, localDe=0, farrayPtr=dst_dummy_r8, rc=status) - _VERIFY(status) - dst_dummy_r8 = 0 + dst_field = ESMF_FieldCreate(spec%grid_out, typekind=kind, & + & indexflag=ESMF_INDEX_DELOCAL, staggerloc=ESMF_STAGGERLOC_CENTER, rc=status) + _VERIFY(status) + if (MAPL_GridHasDE(spec%grid_out)) then + if (kind == ESMF_TYPEKIND_R4) then + call ESMF_FieldGet(dst_field, localDe=0, farrayPtr=dst_dummy_r4, rc=status) + _VERIFY(status) + dst_dummy_r4 = 0 + else if (kind == ESMF_TYPEKIND_R8) then + call ESMF_FieldGet(dst_field, localDe=0, farrayPtr=dst_dummy_r8, rc=status) + _VERIFY(status) + dst_dummy_r8 = 0 + end if end if - end if - counter = counter + 1 + counter = counter + 1 - srcTermProcessing=0 - call ESMF_AttributeGet(spec%grid_in, name='Global',isPresent=isPresent,rc=status) - if (isPresent) then - call ESMF_AttributeGet(spec%grid_in, name='Global',value=global,rc=status) - if (.not.global) unmappedaction=ESMF_UNMAPPEDACTION_IGNORE - end if - select case (spec%regrid_method) - case (REGRID_METHOD_BILINEAR, REGRID_METHOD_BILINEAR_MONOTONIC) - - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & - & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) - _VERIFY(status) - case (REGRID_METHOD_PATCH) - - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_PATCH, & - & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) - _VERIFY(status) - case (REGRID_METHOD_CONSERVE_2ND) - - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, & - & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) - _VERIFY(status) - case (REGRID_METHOD_CONSERVE, REGRID_METHOD_CONSERVE_MONOTONIC, REGRID_METHOD_VOTE, REGRID_METHOD_FRACTION) - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_CONSERVE, & - & srcTermProcessing = srcTermProcessing, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) - _VERIFY(status) - case (REGRID_METHOD_NEAREST_STOD) - call ESMF_FieldRegridStore(src_field, dst_field, & - & regridmethod=ESMF_REGRIDMETHOD_NEAREST_STOD, & - & factorList=factorList, factorIndexList=factorIndexList, & - & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) + srcTermProcessing=0 + call ESMF_AttributeGet(spec%grid_in, name='Global',isPresent=isPresent,rc=status) + if (isPresent) then + call ESMF_AttributeGet(spec%grid_in, name='Global',value=global,rc=status) + if (.not.global) unmappedaction=ESMF_UNMAPPEDACTION_IGNORE + end if + select case (spec%regrid_method) + case (REGRID_METHOD_BILINEAR, REGRID_METHOD_BILINEAR_MONOTONIC) + + call ESMF_FieldRegridStore(src_field, dst_field, & + & regridmethod=ESMF_REGRIDMETHOD_BILINEAR, & + & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) + _VERIFY(status) + case (REGRID_METHOD_PATCH) + + call ESMF_FieldRegridStore(src_field, dst_field, & + & regridmethod=ESMF_REGRIDMETHOD_PATCH, & + & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) + _VERIFY(status) + case (REGRID_METHOD_CONSERVE_2ND) + + call ESMF_FieldRegridStore(src_field, dst_field, & + & regridmethod=ESMF_REGRIDMETHOD_CONSERVE_2ND, & + & linetype=ESMF_LINETYPE_GREAT_CIRCLE, & ! closer to SJ Lin interpolation weights? + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) + _VERIFY(status) + case (REGRID_METHOD_CONSERVE, REGRID_METHOD_CONSERVE_MONOTONIC, REGRID_METHOD_VOTE, REGRID_METHOD_FRACTION) + call ESMF_FieldRegridStore(src_field, dst_field, & + & regridmethod=ESMF_REGRIDMETHOD_CONSERVE, & + & srcTermProcessing = srcTermProcessing, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) + _VERIFY(status) + case (REGRID_METHOD_NEAREST_STOD) + call ESMF_FieldRegridStore(src_field, dst_field, & + & regridmethod=ESMF_REGRIDMETHOD_NEAREST_STOD, & + & factorList=factorList, factorIndexList=factorIndexList, & + & routehandle=route_handle, unmappedaction=unmappedaction, rc=status) + _VERIFY(status) + case default + _FAIL('unknown regrid method') + end select + call ESMF_FieldSMMStore(src_field,dst_field,dummy_rh,transpose_route_handle, & + & factorList,factorIndexList,srcTermProcessing=srcTermProcessing, & + & rc=status) _VERIFY(status) - case default - _FAIL('unknown regrid method') - end select - call ESMF_FieldSMMStore(src_field,dst_field,dummy_rh,transpose_route_handle, & - & factorList,factorIndexList,srcTermProcessing=srcTermProcessing, & - & rc=status) - _VERIFY(status) - call route_handles%insert(spec, route_handle) - call transpose_route_handles%insert(spec, transpose_route_handle) - ! Free resources - deallocate(factorList,factorIndexList) + call route_handles%insert(spec, route_handle) + call transpose_route_handles%insert(spec, transpose_route_handle) + ! Free resources + deallocate(factorList,factorIndexList) - call ESMF_FieldDestroy(src_field, rc=status) - _VERIFY(status) - call ESMF_FieldDestroy(dst_field, rc=status) - _VERIFY(status) + call ESMF_FieldDestroy(src_field, rc=status) + _VERIFY(status) + call ESMF_FieldDestroy(dst_field, rc=status) + _VERIFY(status) + call ESMF_RouteHandleWrite(route_handle,rh_file,_RC) + call ESMF_RouteHandleWrite(transpose_route_handle,rh_trans_file,_RC) + end if end if _RETURN(_SUCCESS) @@ -1652,4 +1669,40 @@ subroutine destroy_route_handle(this, kind, rc) _RETURN(_SUCCESS) end subroutine destroy_route_handle + function generate_rh_name(grid_in,grid_out,rc) result(file_name) + character(len=:), allocatable :: file_name + type(ESMF_Grid), intent(in) :: grid_in + type(ESMF_Grid), intent(in) :: grid_out + integer, intent(out), optional :: rc + + integer :: im_in, jm_in, im_out, jm_out + integer :: nx_in, ny_in, nx_out, ny_out + character(len=5) :: cim_in,cjm_in,cim_out,cjm_out + character(len=5) :: cnx_in,cny_in,cnx_out,cny_out + integer :: temp(3),layout(2) + integer :: status + + call MAPL_GridGet(grid_in,GlobalCellCountPerDim=temp,layout=layout,_RC) + im_in = temp(1) + jm_in = temp(2) + nx_in = layout(1) + ny_in = layout(2) + write(cim_in,'(I5.5)')im_in + write(cjm_in,'(I5.5)')jm_in + write(cnx_in,'(I5.5)')nx_in + write(cny_in,'(I5.5)')ny_in + call MAPL_GridGet(grid_out,GlobalCellCountPerDim=temp,layout=layout,_RC) + im_out = temp(1) + jm_out = temp(2) + nx_out = layout(1) + ny_out = layout(2) + write(cim_out,'(I5.5)')im_out + write(cjm_out,'(I5.5)')jm_out + write(cnx_out,'(I5.5)')nx_out + write(cny_out,'(I5.5)')ny_out + file_name = "rh_"//cim_in//"x"//cjm_in//"_"//cnx_in//"x"//cny_in//"_"//cim_out//"x"//cjm_out//"_"//cnx_out//"x"//cny_out + _RETURN(_SUCCESS) + + end function + end module MAPL_EsmfRegridderMod diff --git a/base/MaplGrid.F90 b/base/MaplGrid.F90 index 0552df9ca01c..da1decaf8e9b 100644 --- a/base/MaplGrid.F90 +++ b/base/MaplGrid.F90 @@ -245,10 +245,11 @@ subroutine GridCoordGet(GRID, coord, name, Location, Units, rc) end subroutine GridCoordGet - subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, RC) + subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, layout, RC) type (ESMF_Grid), intent(IN) :: GRID integer, optional, intent(INout) :: globalCellCountPerDim(:) integer, optional, intent(INout) :: localCellCountPerDim(:) + integer, optional, intent(inout) :: layout(2) integer, optional, intent( OUT) :: RC ! local vars @@ -258,9 +259,14 @@ subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, RC) integer :: maxcounts(ESMF_MAXDIM) integer :: gridRank integer :: UNGRID - integer :: sz, tileCount + integer :: sz, tileCount, dimCount logical :: plocal, pglobal, lxtradim logical :: isPresent,hasDE + type(ESMF_DistGrid) :: distGrid + type(ESMF_VM) :: vm + integer :: ndes + integer, allocatable :: maxindex(:,:),minindex(:,:) + integer, pointer :: ims(:),jms(:) pglobal = present(globalCellCountPerDim) plocal = present(localCellCountPerDim) @@ -325,6 +331,23 @@ subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, RC) end if end if + if (present(layout)) then + call ESMF_GridGet(grid,distgrid=distgrid,dimCount=dimCount,_RC) + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm,petCount=ndes,_RC) + allocate(minindex(dimCount,ndes),maxindex(dimCount,ndes)) + + call MAPL_DistGridGet(distgrid, & + minIndex=minindex, & + maxIndex=maxindex, _RC) + + call MAPL_GetImsJms(Imins=minindex(1,:),Imaxs=maxindex(1,:),& + Jmins=minindex(2,:),Jmaxs=maxindex(2,:),Ims=ims,Jms=jms,_RC) + + layout(1) = size(ims) + layout(2) = size(jms) + end if + _RETURN(ESMF_SUCCESS) end subroutine MAPL_GridGet From 8936d6eb6c41c2cf75eb6554273afca04306449c Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 5 Jan 2024 15:06:02 -0500 Subject: [PATCH 021/141] updates Tom requested --- base/NCIO.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 7098def52134..d2e91705f900 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -3985,9 +3985,11 @@ subroutine create_control_file(filename,jm_world,num_writers,rc) type(ESMF_HConfig) :: hconfig character(len=4) :: resolution character(len=3) :: writers - character(len=128) :: yaml_content + character(len=:), allocatable :: yaml_content - write(resolution,'(I4)')jm_world + _ASSERT(jm_world < 10**5, 'Format not wide enough') + write(resolution,'(I5)')jm_world + _ASSERT(num_writers < 10**3, 'Format not wide enough') write(writers,'(I3)')num_writers yaml_content = "{j_size: "//trim(resolution)//", num_files: "//trim(writers)//"}" hconfig = ESMF_HConfigCreate(content=yaml_content,_RC) From 39e1319992bad49a90809f8e56b22627d9678127 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 8 Jan 2024 11:15:33 -0500 Subject: [PATCH 022/141] fix bug in last commit --- base/NCIO.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index d2e91705f900..8d8883b15161 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -3983,7 +3983,7 @@ subroutine create_control_file(filename,jm_world,num_writers,rc) integer, intent(out), optional :: rc integer :: status type(ESMF_HConfig) :: hconfig - character(len=4) :: resolution + character(len=5) :: resolution character(len=3) :: writers character(len=:), allocatable :: yaml_content From f48f9225d57480d57b1b5bde7dd8abe63fe9c3de Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 2 Feb 2024 09:33:29 -0500 Subject: [PATCH 023/141] get split checkpoint working with server --- base/FileIOShared.F90 | 15 +- base/NCIO.F90 | 476 +++++++++++++++++++++++++++++++-------- generic/MAPL_Generic.F90 | 4 +- 3 files changed, 395 insertions(+), 100 deletions(-) diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 8e252b221b41..714635d776c8 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -102,8 +102,9 @@ module FileIOSharedMod integer :: num_writers = 1 ! only used when writing though o_server logical :: write_restart_by_oserver = .false. - integer :: collection_id = -1 + integer, allocatable :: collection_id(:) character(LEN=ESMF_MAXSTR) :: filename + integer :: writer_id end type ArrDescr @@ -594,11 +595,11 @@ subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) integer, intent(in) :: num_writers integer, optional, intent(out) :: rc - integer :: status, nx, ny, color, ny_by_writers, myid, j + integer :: status, nx, ny, color, ny_by_writers, myid, j, writer_rank nx = size(arrdes%i1) ny = size(arrdes%j1) - _ASSERT(num_writers < ny,'num writers must be less than NY') + _ASSERT(num_writers <= ny,'num writers must be less or equal to than NY') _ASSERT(mod(ny,num_writers)==0,'num writerss must evenly divide NY') call mpi_comm_rank(full_comm,myid, _IERROR) color = arrdes%NX0 @@ -618,7 +619,13 @@ subroutine ArrDescrCreateWriterComm(arrdes, full_comm, num_writers, rc) j = arrdes%NY0 - mod(arrdes%NY0-1,ny_by_writers) call MPI_COMM_SPLIT(full_comm, j, myid, arrdes%IOgathercomm, _IERROR) endif - + if (arrdes%writers_comm /= MPI_COMM_NULL) then + call mpi_comm_rank(arrdes%writers_comm,writer_rank,status) + _VERIFY(STATUS) + end if + call MPI_BCast(writer_rank,1,MPI_INTEGER,0,arrdes%iogathercomm,status) + _VERIFY(STATUS) + arrdes%writer_id = writer_rank _RETURN(_SUCCESS) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 8d8883b15161..f1daa9779752 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -310,8 +310,10 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients integer :: J,K type (ESMF_DistGrid) :: distGrid type (LocalMemReference) :: lMemRef + type (LocalMemReference) :: lMemRef_vec(6) integer :: size_1d logical :: have_oclients + character(len=:), allocatable :: fname_by_writer call ESMF_FieldGet(field, grid=grid, rc=status) _VERIFY(STATUS) @@ -320,7 +322,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) _VERIFY(STATUS) - have_oclients = present(oClients) + have_oclients = present(oClients) call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) _VERIFY(STATUS) @@ -361,7 +363,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call ArrayGather(var_1d, gvar_1d, grid, mask=mask, rc=status) endif - call oClients%collective_stage_data(arrdes%collection_id, trim(arrdes%filename), name, lMemRef, start=[1], & + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1], & global_start=[1], global_count=[size_1d]) else @@ -401,8 +403,24 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call ArrayGather(vr8_1d, gvr8_1d, grid, mask=mask, rc=status) endif - call oClients%collective_stage_data(arrdes%collection_id, trim(arrdes%filename), name, lMemRef, start=[1], & - global_start=[1], global_count=[size_1d]) + if (dims == MAPL_DimsVertOnly .and. arrdes%split_checkpoint) then + do j=1,arrdes%num_writers + fname_by_writer = get_fname_by_rank(trim(arrdes%filename),j-1) + if (mapl_am_i_root()) then + lMemRef_vec(j) = LocalMemReference(pFIO_REAL64,[size_1d]) + call c_f_pointer(lMemRef_vec(j)%base_address, gvr8_1d, shape=[size_1d]) + gvr8_1d = vr8_1d + else + lMemRef_vec(j) = LocalMemReference(pFIO_REAL64,[0]) + call c_f_pointer(lMemRef_vec(j)%base_address, gvr8_1d, shape=[0]) + end if + call oClients%collective_stage_data(arrdes%collection_id(j), trim(fname_by_writer), name, lMemRef_vec(j), start=[1], & + global_start=[1], global_count=[size_1d]) + enddo + else + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1], & + global_start=[1], global_count=[size_1d]) + end if else @@ -437,7 +455,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients do J = 1,size(var_2d,2) call ArrayGather(var_2d(:,J), gvar_2d(:,J), grid, mask=mask, rc=status) enddo - call oClients%collective_stage_data(arrdes%collection_id, trim(arrdes%filename), name, lMemRef, start=[1,1], & + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1,1], & global_start=[1,1], global_count=[arrdes%im_world,size(var_2d,2)]) else @@ -471,7 +489,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients do J = 1,size(vr8_2d,2) call ArrayGather(vr8_2d(:,J), gvr8_2d(:,J), grid, mask=mask, rc=status) enddo - call oClients%collective_stage_data(arrdes%collection_id, trim(arrdes%filename), name, lMemRef, start=[1,1], & + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1,1], & global_start=[1,1], global_count=[arrdes%im_world,size(vr8_2d,2)]) else @@ -509,7 +527,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients enddo enddo - call oClients%collective_stage_data(arrdes%collection_id, trim(arrdes%filename), name, lMemRef, start=[1,1,1], & + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1,1,1], & global_start=[1,1,1], global_count=[arrdes%im_world,size(var_3d,2),size(var_3d,3)]) else @@ -547,7 +565,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients call ArrayGather(vr8_3d(:,J,K), gvr8_3d(:,J,K), grid, mask=mask, rc=status) enddo enddo - call oClients%collective_stage_data(arrdes%collection_id, trim(arrdes%filename), name, lMemRef, start=[1,1,1], & + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1,1,1], & global_start=[1,1,1], global_count=[arrdes%im_world, size(vr8_3d,2), size(vr8_3d,3)]) else @@ -613,22 +631,57 @@ subroutine MAPL_VarWriteNCpar_R4_4d(formatter, name, A, ARRDES, oClients, RC) integer :: status integer :: K, L - integer :: i1, j1, in, jn, global_dim(3) + integer :: i1, j1, in, jn, global_dim(3), dim3, dim4,i type(ArrayReference) :: ref + integer :: start_bound,end_bound,counts_per_writer + logical :: in_bounds + real(kind=ESMF_KIND_R4), pointer :: a_temp(:,:,:,:) + character(len=:), allocatable :: writer_filename if (present(arrdes)) then if (present(oClients)) then - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1,1], & - global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + if (arrdes%split_checkpoint) then + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + counts_per_writer = global_dim(2)/arrdes%num_writers + allocate(a_temp(0,0,0,0)) + do i=1,arrdes%num_writers + start_bound = (i-1)*counts_per_writer+1 + end_bound = i*counts_per_writer + in_bounds = (j1 .ge. start_bound) .and. (jn .le. end_bound) + dim3 = size(a,3) + dim4 = size(a,4) + if (in_bounds) then + ref = ArrayReference(A) + else + ref = ArrayReference(a_temp) + end if + writer_filename = get_fname_by_rank(trim(arrdes%filename),i-1) + call oClients%collective_stage_data(arrdes%collection_id(i),trim(writer_filename),trim(name), & + ref,start=[i1,j1-(i-1)*counts_per_writer,1,1], & + global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2)/arrdes%num_writers,dim3,dim4]) + enddo + _RETURN(_SUCCESS) + else + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1,1], & + global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + _RETURN(_SUCCESS) + end if else do K = 1,size(A,4) do L = 1,size(A,3) @@ -664,21 +717,57 @@ subroutine MAPL_VarWriteNCpar_R8_4d(formatter, name, A, ARRDES, oClients, RC) integer :: status integer :: K, L - integer :: i1, j1, in, jn, global_dim(3) + integer :: i1, j1, in, jn, global_dim(3), dim3, dim4, i type(ArrayReference) :: ref + integer :: start_bound,end_bound,counts_per_writer + logical :: in_bounds + real(kind=ESMF_KIND_R8), pointer :: a_temp(:,:,:,:) + character(len=:), allocatable :: writer_filename if (present(oClients)) then - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1,1], & - global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + + if (arrdes%split_checkpoint) then + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + counts_per_writer = global_dim(2)/arrdes%num_writers + allocate(a_temp(0,0,0,0)) + do i=1,arrdes%num_writers + start_bound = (i-1)*counts_per_writer+1 + end_bound = i*counts_per_writer + in_bounds = (j1 .ge. start_bound) .and. (jn .le. end_bound) + dim3 = size(a,3) + dim4 = size(a,4) + if (in_bounds) then + ref = ArrayReference(A) + else + ref = ArrayReference(a_temp) + end if + writer_filename = get_fname_by_rank(trim(arrdes%filename),i-1) + call oClients%collective_stage_data(arrdes%collection_id(i),trim(writer_filename),trim(name), & + ref,start=[i1,j1-(i-1)*counts_per_writer,1,1], & + global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2)/arrdes%num_writers,dim3,dim4]) + enddo + _RETURN(_SUCCESS) + else + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1,1], & + global_start=[1,1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3),size(a,4)]) + _RETURN(_SUCCESS) + end if else do K = 1,size(A,4) do L = 1,size(A,3) @@ -704,22 +793,65 @@ subroutine MAPL_VarWriteNCpar_R4_3d(formatter, name, A, ARRDES, oClients, RC) integer :: status integer :: l - integer :: i1, j1, in, jn, global_dim(3) + integer :: i1, j1, in, jn, global_dim(3), dim3, i, j1p type(ArrayReference) :: ref + integer :: start_bound,end_bound,counts_per_writer + logical :: in_bounds + real(kind=ESMF_KIND_R4), pointer :: a_temp(:,:,:) + character(len=:), allocatable :: writer_filename + + type(ESMF_VM) :: vm + integer :: mypet + call ESMF_VMGetCurrent(vm) + call ESMF_VMGet(vm,localPet=mypet) if (present(arrdes)) then if (present(oclients)) then - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1], & - global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + if (arrdes%split_checkpoint) then + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + counts_per_writer = global_dim(2)/arrdes%num_writers + allocate(a_temp(0,0,0)) + do i=1,arrdes%num_writers + start_bound = (i-1)*counts_per_writer+1 + end_bound = i*counts_per_writer + in_bounds = (j1 .ge. start_bound) .and. (jn .le. end_bound) + dim3 = size(a,3) + if (in_bounds) then + ref = ArrayReference(A) + j1p = j1-(i-1)*counts_per_writer + else + ref = ArrayReference(a_temp) + j1p = 1 + end if + writer_filename = get_fname_by_rank(trim(arrdes%filename),i-1) + call oClients%collective_stage_data(arrdes%collection_id(i),trim(writer_filename),trim(name), & + ref,start=[i1,j1p,1], & + global_start=[1,1,1], global_count=[global_dim(1),global_dim(2)/arrdes%num_writers,dim3]) + enddo + _RETURN(_SUCCESS) + else + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1], & + global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + _RETURN(_SUCCESS) + end if + else do l=1,size(a,3) call MAPL_VarWrite(formatter,name,A(:,:,l), arrdes=arrdes,lev=l, rc=status) @@ -771,22 +903,54 @@ subroutine MAPL_VarWriteNCpar_R8_3d(formatter, name, A, ARRDES, oClients, RC) integer :: l - integer :: i1, j1, in, jn, global_dim(3) + integer :: i1, j1, in, jn, global_dim(3), dim3, i type(ArrayReference) :: ref - - + integer :: start_bound,end_bound,counts_per_writer + logical :: in_bounds + real(kind=ESMF_KIND_R8), pointer :: a_temp(:,:,:) + character(len=:), allocatable :: writer_filename if (present(oclients)) then - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%i1(arrdes%NX0), "interior starting i not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j not match") - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1,1], & - global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + if (arrdes%split_checkpoint) then + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + counts_per_writer = global_dim(2)/arrdes%num_writers + allocate(a_temp(0,0,0)) + do i=1,arrdes%num_writers + start_bound = (i-1)*counts_per_writer+1 + end_bound = i*counts_per_writer + in_bounds = (j1 .ge. start_bound) .and. (jn .le. end_bound) + dim3 = size(a,3) + if (in_bounds) then + ref = ArrayReference(A) + else + ref = ArrayReference(a_temp) + end if + writer_filename = get_fname_by_rank(trim(arrdes%filename),i-1) + call oClients%collective_stage_data(arrdes%collection_id(i),trim(writer_filename),trim(name), & + ref,start=[i1,j1-(i-1)*counts_per_writer,1], & + global_start=[1,1,1], global_count=[global_dim(1),global_dim(2)/arrdes%num_writers,dim3]) + enddo + _RETURN(_SUCCESS) + else + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & + ref,start=[i1,j1,1], & + global_start=[1,1,1], global_count=[global_dim(1),global_dim(2),size(a,3)]) + _RETURN(_SUCCESS) + end if else do l=1,size(a,3) call MAPL_VarWrite(formatter,name,A(:,:,l),arrdes,lev=l, rc=status) @@ -843,23 +1007,56 @@ subroutine MAPL_VarWriteNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, oC integer, allocatable :: recvcounts(:), displs(:) type (ArrayReference) :: ref - integer :: i1, j1, in, jn, global_dim(3) + integer :: i1, j1, in, jn, global_dim(3), jp1 + integer :: start_bound,end_bound,counts_per_writer + logical :: in_bounds + real(kind=ESMF_KIND_R4), pointer :: a_temp(:,:) + character(len=:), allocatable :: writer_filename if (present(arrdes)) then if(present(oClients)) then - call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) - _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") - _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") - - ref = ArrayReference(A) - _ASSERT( size(a,1) == in-i1+1, "size not match") - _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & - ref,start=[i1,j1], & - global_start=[1,1], global_count=[global_dim(1),global_dim(2)]) - _RETURN(_SUCCESS) + if (arrdes%split_checkpoint) then + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + counts_per_writer = global_dim(2)/arrdes%num_writers + allocate(a_temp(0,0)) + do i=1,arrdes%num_writers + start_bound = (i-1)*counts_per_writer+1 + end_bound = i*counts_per_writer + in_bounds = (j1 .ge. start_bound) .and. (jn .le. end_bound) + if (in_bounds) then + ref = ArrayReference(A) + jp1 = j1 - (i-1)*counts_per_writer + else + ref = ArrayReference(a_temp) + jp1 = 1 + end if + writer_filename = get_fname_by_rank(trim(arrdes%filename),i-1) + call oClients%collective_stage_data(arrdes%collection_id(i),trim(writer_filename),trim(name), & + ref,start=[i1,jp1], & + global_start=[1,1], global_count=[global_dim(1),global_dim(2)/arrdes%num_writers]) + enddo + _RETURN(_SUCCESS) + else + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & + ref,start=[i1,j1], & + global_start=[1,1], global_count=[global_dim(1),global_dim(2)]) + _RETURN(_SUCCESS) + end if end if endif @@ -1709,7 +1906,7 @@ subroutine MAPL_VarWriteNCpar_R8_1d(formatter, name, A, layout, ARRDES, MASK, of call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) _VERIFY(STATUS) - if (io_rank == 0) then + if (io_rank == 0 .or. arrdes%split_checkpoint) then call formatter%put_var(trim(name),A,start=start,count=cnt,rc=status) if(status /= NF90_NOERR) then print*,trim(IAm),'Error writing variable ',status @@ -2324,10 +2521,57 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, oC integer :: start(4), cnt(4) integer :: jsize, jprev, num_io_rows integer, allocatable :: recvcounts(:), displs(:) - type (ArrayReference) :: ref integer :: i1, j1, in, jn, global_dim(3) + integer :: start_bound,end_bound,counts_per_writer + logical :: in_bounds + real(kind=ESMF_KIND_R8), pointer :: a_temp(:,:) + character(len=:), allocatable :: writer_filename + if (present(arrdes)) then + if(present(oClients)) then + if (arrdes%split_checkpoint) then + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + counts_per_writer = global_dim(2)/arrdes%num_writers + allocate(a_temp(0,0)) + do i=1,arrdes%num_writers + start_bound = (i-1)*counts_per_writer+1 + end_bound = i*counts_per_writer + in_bounds = (j1 .ge. start_bound) .and. (jn .le. end_bound) + if (in_bounds) then + ref = ArrayReference(A) + else + ref = ArrayReference(a_temp) + end if + writer_filename = get_fname_by_rank(trim(arrdes%filename),i-1) + call oClients%collective_stage_data(arrdes%collection_id(i),trim(writer_filename),trim(name), & + ref,start=[i1,j1-(i-1)*counts_per_writer], & + global_start=[1,1], global_count=[global_dim(1),global_dim(2)/arrdes%num_writers]) + enddo + _RETURN(_SUCCESS) + else + call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + call MAPL_Grid_interior(arrdes%grid,i1,in,j1,jn) + _ASSERT( i1 == arrdes%I1(arrdes%NX0), "interior starting i1 not match") + _ASSERT( j1 == arrdes%j1(arrdes%NY0), "interior starting j1 not match") + + ref = ArrayReference(A) + _ASSERT( size(a,1) == in-i1+1, "size not match") + _ASSERT( size(a,2) == jn-j1+1, "size not match") + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & + ref,start=[i1,j1], & + global_start=[1,1], global_count=[global_dim(1),global_dim(2)]) + _RETURN(_SUCCESS) + end if + end if + endif if (present(arrdes)) then if(present(oClients)) then call MAPL_GridGet(arrdes%grid,globalCellCountPerDim=global_dim,rc=status) @@ -2338,7 +2582,7 @@ subroutine MAPL_VarWriteNCpar_R8_2d(formatter, name, A, ARRDES, lev, offset2, oC ref = ArrayReference(A) _ASSERT( size(a,1) == in-i1+1, "size not match") _ASSERT( size(a,2) == jn-j1+1, "size not match") - call oClients%collective_stage_data(arrdes%collection_id,trim(arrdes%filename),trim(name), & + call oClients%collective_stage_data(arrdes%collection_id(1),trim(arrdes%filename),trim(name), & ref,start=[i1,j1], & global_start=[1,1], global_count=[global_dim(1),global_dim(2)]) _RETURN(_SUCCESS) @@ -2659,9 +2903,9 @@ subroutine MAPL_BundleReadNCPar(Bundle, arrdes, filename, rc) _VERIFY(STATUS) else if(arrdes%split_restart .and. .not. arrdes%tile) then - + call MPI_COMM_RANK(arrdes%readers_comm,reader_rank,status) - _VERIFY(STATUS) + _VERIFY(STATUS) fname_by_rank = get_fname_by_rank(trim(filename),reader_rank) call formatter%open(trim(fname_by_rank),pFIO_READ,rc=status) _VERIFY(STATUS) @@ -2808,7 +3052,7 @@ subroutine MAPL_StateVarReadNCPar(filename, STATE, arrdes, bootstrapable, NAME, logical :: tile integer :: nVarFile, ncid - character(len=ESMF_MAXSTR), allocatable :: VarNamesFile(:) + character(len=ESMF_MAXSTR), allocatable :: VarNamesFile(:) type(ESMF_VM) :: VM logical :: foundInFile integer :: dna @@ -3465,7 +3709,7 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) ndims = ndims + 1 !WJ note: if arrdes%write_restart_by_oserver is true, all processors will participate - if (arrdes%writers_comm/=MPI_COMM_NULL .or. have_oclients ) then + !if (arrdes%writers_comm/=MPI_COMM_NULL .or. have_oclients ) then !bmaa ! Create dimensions as needed if (Have_HorzVert .or. Have_HorzOnly) then @@ -3498,7 +3742,11 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) if (isCubed) then x0=1.0d0 - x1=dble(arrdes%JM_WORLD) + if (arrdes%split_checkpoint) then + x1 = dble(arrdes%jm_world/arrdes%num_writers) + else + x1=dble(arrdes%JM_WORLD) + end if else if (arrdes%jm_world==1) then x0=0.0 @@ -3508,7 +3756,19 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) x1=90.0d0 end if endif - lat = MAPL_Range(x0,x1,arrdes%JM_WORLD) + if (arrdes%split_checkpoint) then + lat = MAPL_Range(x0,x1,arrdes%JM_WORLD/arrdes%num_writers) + call cf%add_dimension('lat',arrdes%jm_world/arrdes%num_writers,rc=status) + _VERIFY(status) + allocate(coordinate_data,source=lat) + allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) + else if ( (.not.arrdes%split_checkpoint) .and. (arrdes%writers_comm /= MPI_Comm_Null)) then + lat = MAPL_Range(x0,x1,arrdes%JM_WORLD) + call cf%add_dimension('lat',arrdes%jm_world,rc=status) + _VERIFY(status) + allocate(coordinate_data,source=lat) + allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) + endif if (arrdes%split_checkpoint) then call cf%add_dimension('lat',arrdes%jm_world/arrdes%num_writers,rc=status) @@ -3517,8 +3777,8 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) integer :: j0, j1, block_size,ny ny = size(arrdes%jn) block_size = ny/arrdes%num_writers - j0 = arrdes%j1(arrdes%myrow+1) - j1 = arrdes%jn(arrdes%myrow+1+block_size-1) + j0 = arrdes%j1(arrdes%writer_id*block_size+1) + j1 = arrdes%jn((arrdes%writer_id+1)*block_size) allocate(coordinate_data,source=lat(j0:j1)) end block allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) @@ -3827,21 +4087,50 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) call MPI_Info_set(info,"cb_buffer_size", trim(arrdes%cb_buffer_size),STATUS) _VERIFY(STATUS) +! now write the files - if (have_oclients) then - call oClients%set_optimal_server(1) + if (have_oclients) then + call oClients%set_optimal_server(1) + if (arrdes%split_checkpoint) then + if (.not.allocated(arrdes%collection_id)) allocate(arrdes%collection_id(arrdes%num_writers)) + do i=1,arrdes%num_writers + fname_by_writer = get_fname_by_rank(trim(filename),i-1) + iter = RstCollections%find(trim(fname_by_writer)) + if (iter == RstCollections%end()) then + call cf%add_attribute("Split_Cubed_Sphere", i, _RC) + arrdes%collection_id(i) = oClients%add_hist_collection(cf) + call RstCollections%insert(trim(fname_by_writer), arrdes%collection_id(i)) + else + arrdes%collection_id(i) = iter%value() + call oClients%modify_metadata(arrdes%collection_id(i), var_map = var_map, rc=status) + _VERIFY(status) + endif + arrdes%filename = trim(filename) + enddo + if (arrdes%writers_comm /= mpi_comm_null) then + call mpi_comm_rank(arrdes%writers_comm,writer_rank,status) + _VERIFY(STATUS) + if (writer_rank == 0) then + call create_control_file(filename,arrdes%im_world,arrdes%num_writers,rc) + end if + end if + else + if (.not.allocated(arrdes%collection_id)) allocate(arrdes%collection_id(1)) iter = RstCollections%find(trim(BundleName)) if (iter == RstCollections%end()) then - arrdes%collection_id = oClients%add_hist_collection(cf) - call RstCollections%insert(trim(BundleName), arrdes%collection_id) + arrdes%collection_id(1) = oClients%add_hist_collection(cf) + call RstCollections%insert(trim(BundleName), arrdes%collection_id(1)) else - arrdes%collection_id = iter%value() - call oClients%modify_metadata(arrdes%collection_id, var_map = var_map, rc=status) + arrdes%collection_id(1) = iter%value() + call oClients%modify_metadata(arrdes%collection_id(1), var_map = var_map, rc=status) _VERIFY(status) endif arrdes%filename = trim(filename) - else ! not written by oserver + end if + else + + if (arrdes%writers_comm /= mpi_comm_null) then if (arrdes%num_writers == 1) then call formatter%create(trim(filename), rc=status) _VERIFY(status) @@ -3865,9 +4154,8 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) call formatter%write(cf,rc=status) _VERIFY(STATUS) end if - endif ! write_restart_by_oserver - - endif !am writer or write_restart_by_oserver + end if + endif ! write_restart_by_oserver do l=1,nVars call ESMF_FieldBundleGet(bundle, fieldIndex=l, field=field, rc=status) @@ -3991,7 +4279,7 @@ subroutine create_control_file(filename,jm_world,num_writers,rc) write(resolution,'(I5)')jm_world _ASSERT(num_writers < 10**3, 'Format not wide enough') write(writers,'(I3)')num_writers - yaml_content = "{j_size: "//trim(resolution)//", num_files: "//trim(writers)//"}" + yaml_content = "{j_size: "//trim(resolution)//", num_files: "//trim(writers)//"}" hconfig = ESMF_HConfigCreate(content=yaml_content,_RC) call ESMF_HConfigFileSave(hconfig,trim(filename),_RC) _RETURN(_SUCCESS) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index 233fbb1f8f93..fd92d7822f9a 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -1188,8 +1188,8 @@ subroutine set_checkpoint_restart_options(rc) if (trim(write_restart_by_oserver) == 'YES') then ! reset other choices ! io_rank 0 becomes the root - num_writers = 1 - split_checkpoint = 'NO' + !num_writers = 1 + !split_checkpoint = 'NO' mygrid%write_restart_by_oserver = .true. endif From 02a16d415fddb1b5b7dbef74668370fb4e2f3a17 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 2 Feb 2024 10:48:07 -0500 Subject: [PATCH 024/141] fix bug --- base/NCIO.F90 | 26 ++++---------------------- 1 file changed, 4 insertions(+), 22 deletions(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index f1daa9779752..aae39128bfd2 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -3756,38 +3756,20 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) x1=90.0d0 end if endif - if (arrdes%split_checkpoint) then - lat = MAPL_Range(x0,x1,arrdes%JM_WORLD/arrdes%num_writers) - call cf%add_dimension('lat',arrdes%jm_world/arrdes%num_writers,rc=status) - _VERIFY(status) - allocate(coordinate_data,source=lat) - allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) - else if ( (.not.arrdes%split_checkpoint) .and. (arrdes%writers_comm /= MPI_Comm_Null)) then - lat = MAPL_Range(x0,x1,arrdes%JM_WORLD) - call cf%add_dimension('lat',arrdes%jm_world,rc=status) - _VERIFY(status) - allocate(coordinate_data,source=lat) - allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) - endif - if (arrdes%split_checkpoint) then + lat = MAPL_Range(x0,x1,arrdes%JM_WORLD/arrdes%num_writers) call cf%add_dimension('lat',arrdes%jm_world/arrdes%num_writers,rc=status) _VERIFY(status) - block - integer :: j0, j1, block_size,ny - ny = size(arrdes%jn) - block_size = ny/arrdes%num_writers - j0 = arrdes%j1(arrdes%writer_id*block_size+1) - j1 = arrdes%jn((arrdes%writer_id+1)*block_size) - allocate(coordinate_data,source=lat(j0:j1)) - end block + allocate(coordinate_data,source=lat) allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) else + lat = MAPL_Range(x0,x1,arrdes%JM_WORLD) call cf%add_dimension('lat',arrdes%jm_world,rc=status) _VERIFY(status) allocate(coordinate_data,source=lat) allocate(var,source=CoordinateVariable(Variable(type=pFIO_REAL64,dimensions='lat'),coordinate_data)) endif + call var%add_attribute('units','degrees_north') call var%add_attribute('long_name','Latitude') call cf%add_variable('lat',var,rc=status) From 22368f7b30fde8d9b564185958b761751de78116 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 2 Feb 2024 15:08:19 -0500 Subject: [PATCH 025/141] more updates for the split restart capability --- Apps/CMakeLists.txt | 2 + Apps/combine_restarts.py | 151 ++++++++++++++++++++++++++++++++++++ Apps/split_restart.py | 160 +++++++++++++++++++++++++++++++++++++++ CHANGELOG.md | 1 + 4 files changed, 314 insertions(+) create mode 100755 Apps/combine_restarts.py create mode 100755 Apps/split_restart.py diff --git a/Apps/CMakeLists.txt b/Apps/CMakeLists.txt index 41cd7462a4a7..b7bd439685ed 100644 --- a/Apps/CMakeLists.txt +++ b/Apps/CMakeLists.txt @@ -10,6 +10,8 @@ file (COPY mapl_stub.pl DESTINATION ${esma_etc}/MAPL) install (PROGRAMS MAPL_GridCompSpecs_ACG.py + combine_restarts.py + split_restart.py mapl_acg.pl mapl_stub.pl TYPE SYSCONF diff --git a/Apps/combine_restarts.py b/Apps/combine_restarts.py new file mode 100755 index 000000000000..f92ee0d25122 --- /dev/null +++ b/Apps/combine_restarts.py @@ -0,0 +1,151 @@ +#!/usr/bin/env python + +#------------- +# Load modules +#------------- +from netCDF4 import Dataset +import numpy +import argparse +import yaml + +def parse_args(): + p = argparse.ArgumentParser(description='Flatten a lat-lon to 1D') + p.add_argument('input',type=str,help='input file',default=None) + p.add_argument('output',type=str,help='output file',default=None) + return vars(p.parse_args()) + +#------------------ +# Opening the file +#------------------ +comm_args = parse_args() +Input_template = comm_args['input'] +Output_file = comm_args['output'] + +f = open(Input_template,'r') +input_yaml = yaml.safe_load(f) +f.close() +num_files = input_yaml['num_files'] +j_size = input_yaml['j_size'] + +j_per_file = j_size*6//num_files + +ncFid = Dataset(Input_template+"_"+str(1), mode='r') +ncFidOut = Dataset(Output_file, mode='w', format='NETCDF4') + +#--------------------- +# Extracting variables +#--------------------- + +old_time = ncFid.variables['time'][:] + +exclude_dims = ['time','lon','lat'] +detected_dims = [] +for dim in ncFid.dimensions: + if dim not in exclude_dims: + detected_dims.append(dim) +cube_res = len(ncFid.dimensions['lon']) + +# define dimenions + +Xdim = ncFidOut.createDimension('lon',cube_res) +Ydim = ncFidOut.createDimension('lat',cube_res*6) + +for dim in detected_dims: + dim_out = ncFidOut.createDimension(dim,len(ncFid.dimensions[dim])) + +new_time_dim = ncFidOut.createDimension('time',1) + +# define coordinate variables + +new_time = ncFidOut.createVariable('time','f8',('time')) +for att in ncFid.variables['time'].ncattrs(): + for att in ncFid.variables['time'].ncattrs(): + setattr(ncFidOut.variables['time'],att,getattr(ncFid.variables['time'],att)) + new_time[:] = 0 + + +vXdim = ncFidOut.createVariable('lon','f8',('lon')) +vYdim = ncFidOut.createVariable('lat','f8',('lat')) +setattr(ncFidOut.variables['lon'],'units','degrees_east') +setattr(ncFidOut.variables['lat'],'units','degrees_north') +setattr(ncFidOut.variables['lon'],'long_name','longitude') +setattr(ncFidOut.variables['lat'],'long_name','latitude') +vXdim[:]=range(1,cube_res+1) +vYdim[:]=range(1,(cube_res*6)+1) + +for dim in detected_dims: + if dim in ncFid.variables: + vLevOut = ncFidOut.createVariable(dim,'f8',(dim)) + for att in ncFid.variables[dim].ncattrs(): + setattr(ncFidOut.variables[dim],att,getattr(ncFid.variables[dim],att)) + dim_size = len(ncFid.dimensions[dim])+1 + vLevOut[:] = range(1,dim_size) + +# special handling if fvcore restart for AK/BK or pref +oned_vars = ['AK','BK','PREF'] +for oned_var in oned_vars: + if oned_var in ncFid.variables: + float_type = ncFid.variables[oned_var].dtype + ak= ncFidOut.createVariable(oned_var,float_type,('edge')) + for att in ncFid.variables[oned_var].ncattrs(): + setattr(ncFidOut.variables[oned_var],att,getattr(ncFid.variables[oned_var],att)) + ak[:] = ncFid.variables[oned_var][:] + +ncFid.close() + +Exclude_Var = ['time','edge','lev','lon','lat','AK','BK','unknown_dim1','unknown_dim2'] + +for i in range(num_files): + ncFid = Dataset(Input_template+"_"+str(i), mode='r') + if i==0: + for var in ncFid.variables: + if var not in Exclude_Var: + temp = ncFid.variables[var][:] + dim_size =len(temp.shape) + float_type = ncFid.variables[var].dtype + var_dims = ncFid.variables[var].dimensions + + if dim_size == 4: + tout = ncFidOut.createVariable(var,float_type,var_dims,fill_value=1.0e15,chunksizes=(1,1,cube_res,cube_res)) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + elif dim_size == 3: + tout = ncFidOut.createVariable(var,float_type,var_dims,fill_value=1.0e15,chunksizes=(1,cube_res,cube_res)) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + elif dim_size == 2: + tout = ncFidOut.createVariable(var,float_type,('lat','lon'),fill_value=1.0e15,chunksizes=(cube_res,cube_res)) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + + for var in ncFid.variables: + if var not in Exclude_Var: + temp = ncFid.variables[var][:] + dim_size =len(temp.shape) + tout = ncFidOut.variables[var][:] + + if dim_size == 4: + il = j_per_file*i + iu = j_per_file*(i+1) + ncFidOut.variables[var][:,:,il:iu,:] = temp[:,:,:,:] + + elif dim_size == 3: + il = j_per_file*i + iu = j_per_file*(i+1) + ncFidOut.variables[var][:,il:iu,:] = temp[:,:,:] + + elif dim_size == 2: + il = j_per_file*i + iu = j_per_file*(i+1) + ncFidOut.variables[var][il:iu,:] = temp[:,:] + + ncFid.close() + +#----------------- +# Closing the file +#----------------- +ncFidOut.close() + diff --git a/Apps/split_restart.py b/Apps/split_restart.py new file mode 100755 index 000000000000..97468a6ac584 --- /dev/null +++ b/Apps/split_restart.py @@ -0,0 +1,160 @@ +#!/usr/bin/env python + +#------------- +# Load modules +#------------- +from netCDF4 import Dataset +import numpy +import argparse +import sys + +def parse_args(): + p = argparse.ArgumentParser(description='Flatten a lat-lon to 1D') + p.add_argument('input',type=str,help='input file',default=None) + p.add_argument('output',type=str,help='output file',default=None) + p.add_argument('split',type=int,help='number of files to split into',default=None) + return vars(p.parse_args()) + +#------------------ +# Opening the file +#------------------ +comm_args = parse_args() +Input_file = comm_args['input'] +Output_template = comm_args['output'] +n_files = comm_args['split'] + +ncFid = Dataset(Input_file,mode='r') + +if 'tile' in ncFid.dimensions: + quit() + +#--------------------- +# Extracting variables +#--------------------- + +old_time = ncFid.variables['time'][:] + +exclude_dims = ['time','lon','lat'] +detected_dims = [] +for dim in ncFid.dimensions: + if dim not in exclude_dims: + detected_dims.append(dim) + +cube_res = len(ncFid.dimensions['lon']) + +Exclude_Var = ['time','edge','lev','lon','lat','AK','BK','unknown_dim1','unknown_dim2'] + +remainder = (cube_res*6)%n_files +if remainder != 0: + raise ValueError('number of files my evenly divide 6 times cube size') + +y_size = cube_res*6//n_files + +# create master file +f = open(Output_template,mode='w') +out_master = "num_files: "+str(n_files)+"\n"+"j_size: "+str(cube_res) +f.write(out_master) +f.close() +# create each file +for i in range(n_files): + ncFidOut = Dataset(Output_template+"_"+str(i), mode='w',format='NETCDF4') + setattr(ncFidOut,'Split_Cubed_Sphere',i) + + # define dimenions + + Xdim = ncFidOut.createDimension('lon',cube_res) + Ydim = ncFidOut.createDimension('lat',y_size) + + for dim in detected_dims: + dim_out = ncFidOut.createDimension(dim,len(ncFid.dimensions[dim])) + + new_time_dim = ncFidOut.createDimension('time',1) + + # define coordinate variables + + new_time = ncFidOut.createVariable('time','f8',('time')) + for att in ncFid.variables['time'].ncattrs(): + for att in ncFid.variables['time'].ncattrs(): + setattr(ncFidOut.variables['time'],att,getattr(ncFid.variables['time'],att)) + new_time[:] = 0 + + + vXdim = ncFidOut.createVariable('lon','f8',('lon')) + vYdim = ncFidOut.createVariable('lat','f8',('lat')) + setattr(ncFidOut.variables['lon'],'units','degrees_east') + setattr(ncFidOut.variables['lat'],'units','degrees_north') + setattr(ncFidOut.variables['lon'],'long_name','longitude') + setattr(ncFidOut.variables['lat'],'long_name','latitude') + y_start = i*y_size + vXdim[:]=range(1,cube_res+1) + vYdim[:]=range(1+y_start,y_size+1+y_start) + + for dim in detected_dims: + if dim in ncFid.variables: + vLevOut = ncFidOut.createVariable(dim,'f8',(dim)) + for att in ncFid.variables[dim].ncattrs(): + setattr(ncFidOut.variables[dim],att,getattr(ncFid.variables[dim],att)) + dim_size = len(ncFid.dimensions[dim])+1 + vLevOut[:] = range(1,dim_size) + + # special handling if fvcore restart for AK/BK or pref + oned_vars = ['AK','BK','PREF'] + for oned_var in oned_vars: + if oned_var in ncFid.variables: + float_type = ncFid.variables[oned_var].dtype + ak= ncFidOut.createVariable(oned_var,float_type,('edge')) + for att in ncFid.variables[oned_var].ncattrs(): + setattr(ncFidOut.variables[oned_var],att,getattr(ncFid.variables[oned_var],att)) + ak[:] = ncFid.variables[oned_var][:] + + # define variables + for var in ncFid.variables: + if var not in Exclude_Var: + temp = ncFid.variables[var][:] + dim_size =len(temp.shape) + float_type = ncFid.variables[var].dtype + var_dims = ncFid.variables[var].dimensions + if dim_size == 4: + tout = ncFidOut.createVariable(var,float_type,var_dims,fill_value=1.0e15,chunksizes=(1,1,cube_res,cube_res)) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + elif dim_size == 3: + tout = ncFidOut.createVariable(var,float_type,var_dims,fill_value=1.0e15,chunksizes=(1,cube_res,cube_res)) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + elif dim_size == 2: + tout = ncFidOut.createVariable(var,float_type,('lat','lon'),fill_value=1.0e15,chunksizes=(cube_res,cube_res)) + for att in ncFid.variables[var].ncattrs(): + if att != "_FillValue": + setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) + + for var in ncFid.variables: + if var not in Exclude_Var: + temp = ncFid.variables[var][:] + dim_size =len(temp.shape) + tout = ncFidOut.variables[var][:] + + if dim_size == 4: + il = y_size*i + iu = y_size*(i+1) + ncFidOut.variables[var][:,:,:,:] = temp[:,:,il:iu,:] + + elif dim_size == 3: + il = y_size*i + iu = y_size*(i+1) + ncFidOut.variables[var][:,:,:] = temp[:,il:iu,:] + + elif dim_size == 2: + il = y_size*i + iu = y_size*(i+1) + ncFidOut.variables[var][:,:] = temp[il:iu,:] + + ncFidOut.close() + +#----------------- +# Closing the file +#----------------- +ncFid.close() + diff --git a/CHANGELOG.md b/CHANGELOG.md index 43b8f612b25d..a70eeb2494a6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files - Convert from ABI Fixed Grid to lon/lat coordinates used in MAPL_XYGridFactory (supporting geostationary GOES-R series) From 28c6151b4bf9cd94f327e1b290f662cf4bdd69b0 Mon Sep 17 00:00:00 2001 From: Atanas Trayanov Date: Thu, 8 Feb 2024 20:05:06 -0500 Subject: [PATCH 026/141] Implements more efficient reading of tile files --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6dcd08ebfdcf..29c80ab5d699 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,10 +8,12 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- implemented a new algorthm to read tile files ### Changed ### Fixed +- removed unnecessary memory allocation for tile reads. This is critical for high res runs on SCU17 ### Removed From 8c112b4d4a207a7a9f9789e66f93063091195932 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 12 Feb 2024 09:36:01 -0700 Subject: [PATCH 027/141] Add mask for a geostationary satellite, also called a geosat or geosynchronous satellite --- base/Base/Base_Base_implementation.F90 | 18 +- base/MAPL_ObsUtil.F90 | 154 +++- base/MAPL_SwathGridFactory.F90 | 59 +- base/Plain_netCDF_Time.F90 | 115 ++- gridcomps/History/CMakeLists.txt | 2 + gridcomps/History/MAPL_HistoryCollection.F90 | 2 + gridcomps/History/MAPL_HistoryGridComp.F90 | 79 +- .../History/MAPL_HistoryMaskGeosatMod.F90 | 179 ++++ .../MAPL_HistoryMaskGeosatMod_smod.F90 | 797 ++++++++++++++++++ .../History/MAPL_HistoryTrajectoryMod.F90 | 2 + .../MAPL_HistoryTrajectoryMod_smod.F90 | 89 +- gridcomps/History/MAPL_StationSamplerMod.F90 | 74 +- 12 files changed, 1426 insertions(+), 144 deletions(-) create mode 100644 gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 create mode 100644 gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 2aef8eb3ecc8..dfeba20408e2 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2771,10 +2771,12 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, logical :: good_grid - if (npts == 0 ) then - _RETURN(_SUCCESS) - endif +! if (npts == 0 ) then +! _RETURN(_SUCCESS) +! endif + write(6,*) 'pt 1' + if ( .not. present(grid)) then _FAIL("need a cubed-sphere grid") endif @@ -2789,6 +2791,8 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, good_grid = grid_is_ok(grid) _ASSERT( good_grid, "MAPL_GetGlobalHorzIJIndex cannot handle this grid") + write(6,*) 'pt 2' + allocate(lons(npts),lats(npts)) if (present(lon) .and. present(lat)) then lons = lon @@ -2821,8 +2825,12 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, II = -1 JJ = -1 - ! The edge points are assigned in the order of face 1,2,3,4,5,6 + ! ygyu when npts=0 on localDE, + if (npts == 0 ) then + _RETURN(_SUCCESS) + endif + ! The edge points are assigned in the order of face 1,2,3,4,5,6 call calculate(x,y,z,II,JJ) _RETURN(_SUCCESS) @@ -2849,7 +2857,7 @@ elemental subroutine calculate(x, y, z, i, j) elseif (abs(z-1.0d0) <= tolerance) then call angle_to_index(-x, -y, i, j) J = J + IM_WORLD*2 - ! face = 4 + ! face = 4 elseif (abs(x+1.0d0) <= tolerance) then call angle_to_index(-z, -y, i, j) J = J + IM_WORLD*3 diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 0329e8e16311..fa8a5a53870c 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -35,6 +35,7 @@ module MAPL_ObsUtilMod real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: times_R8(:) + integer, allocatable :: location_index_ioda(:) real(kind=REAL32), allocatable :: p2d(:) real(kind=REAL32), allocatable :: p3d(:,:) end type obs_unit @@ -57,6 +58,11 @@ module MAPL_ObsUtilMod module procedure sort_four_arrays_by_time end interface sort_multi_arrays_by_time + interface apply_order_index + module procedure apply_order_index_R8 + module procedure apply_order_index_I4 + end interface apply_order_index + contains subroutine get_obsfile_Tbracket_from_epoch(currTime, & @@ -104,7 +110,7 @@ subroutine get_obsfile_Tbracket_from_epoch(currTime, & Ts = T1 + dTs Te = T1 + dTe - obsfile_Ts_index = n1 + obsfile_Ts_index = n1 - 1 ! downshift by 1 obsfile_Te_index = n2 _RETURN(ESMF_SUCCESS) @@ -166,6 +172,71 @@ subroutine time_real_to_ESMF (times_R8_1d, times_esmf_1d, datetime_units, rc) end subroutine time_real_to_ESMF + subroutine time_ESMF_to_real (times_R8_1d, times_esmf_1d, datetime_units, rc) + use MAPL_NetCDF, only : convert_NetCDF_DateTime_to_ESMF + + type(ESMF_Time), intent(in) :: times_esmf_1d(:) + real(kind=ESMF_KIND_R8), intent(inout) :: times_R8_1d(:) + character(len=*), intent(in) :: datetime_units + integer, optional, intent(out) :: rc + + type(ESMF_TimeInterval) :: interval, t_interval + type(ESMF_Time) :: time0 + type(ESMF_Time) :: time1 + character(len=:), allocatable :: tunit + + integer :: i, len + integer :: int_time + integer :: status + + len = size (times_esmf_1d) + int_time = 0 + call convert_NetCDF_DateTime_to_ESMF(int_time, datetime_units, interval, & + time0, time=time1, time_unit=tunit, _RC) + + do i=1, len + t_interval = times_esmf_1d(i) - time0 + select case(trim(tunit)) + case ('days') + call ESMF_TimeIntervalGet(t_interval,d_r8=times_R8_1d(i),_RC) + case ('hours') + call ESMF_TimeIntervalGet(t_interval,h_r8=times_R8_1d(i),_RC) + case ('minutes') + call ESMF_TimeIntervalGet(t_interval,m_r8=times_R8_1d(i),_RC) + case ('seconds') + call ESMF_TimeIntervalGet(t_interval,s_r8=times_R8_1d(i),_RC) + case default + _FAIL('illegal value for tunit: '//trim(tunit)) + end select + enddo + + _RETURN(_SUCCESS) + end subroutine time_ESMF_to_real + + + subroutine create_timeunit (time, datetime_units, input_unit, rc) + type(ESMF_Time), intent(in) :: time + character(len=*), intent(out) :: datetime_units + character(len=*), optional, intent(in) :: input_unit + + integer, optional, intent(out) :: rc + + integer :: i, len + integer :: status + character(len=20) :: string + + call ESMF_timeget (time, timestring=string, _RC) + if (present(input_unit)) then + datetime_units = trim(input_unit)//' since '//trim(string) + else + datetime_units = 'seconds since '//trim(string) + end if + !!print*, 'datetime_units:', trim(datetime_units) + + _RETURN(_SUCCESS) + end subroutine create_timeunit + + subroutine reset_times_to_current_day(current_time, times_1d, rc) type(ESMF_Time), intent(in) :: current_time type(ESMF_Time), intent(inout) :: times_1d(:) @@ -182,8 +253,6 @@ subroutine reset_times_to_current_day(current_time, times_1d, rc) end subroutine reset_times_to_current_day - - ! --//-------------------------------------//-> ! files ! o o o o o o o o o o T: filename @@ -250,12 +319,14 @@ subroutine Find_M_files_for_currTime (currTime, & ! print*, 'ck dT0_s, dT1_s, dT2_s', dT0_s, dT1_s, dT2_s ! print*, '1st n1, n2', n1, n2 - obsfile_Ts_index = n1 - if ( dT2_s - n2*dT0_s < 1 ) then - obsfile_Te_index = n2 - 1 - else - obsfile_Te_index = n2 - end if + obsfile_Ts_index = n1 - 1 ! downshift by 1 + obsfile_Te_index = n2 +! if ( dT2_s - n2*dT0_s < 1 ) then +! obsfile_Te_index = n2 - 1 +! else +! obsfile_Te_index = n2 +! end if + ! put back n1 = obsfile_Ts_index @@ -425,9 +496,6 @@ subroutine read_M_files_4_swath ( filenames, Xdim, Ydim, & !!write(6,'(5f20.2)') time_loc_R8(1,j) end do - !!write(6,'(2x,a,10i10)') 'end of file id', i - !!write(6,*) - deallocate(time_loc_R8) deallocate(lon_loc) deallocate(lat_loc) @@ -668,6 +736,68 @@ subroutine sort_four_arrays_by_time(U,V,T,ID,rc) end subroutine sort_four_arrays_by_time + subroutine sort_index (X, IA, rc) + use MAPL_SortMod + real(ESMF_KIND_R8), intent(in) :: X(:) + integer, intent(out) :: IA(:) ! index + integer, optional, intent(out) :: rc + + integer :: i, len + integer(ESMF_KIND_I8), allocatable :: IX(:) + + _ASSERT (size(X)==size(IA), 'X and IA (its index) differ in dimension') + len = size (X) + allocate (IX(len)) + do i=1, len + IX(i)=X(i) + IA(i)=i + enddo + call MAPL_Sort(IX,IA) + _RETURN(_SUCCESS) + + end subroutine sort_index + + + subroutine apply_order_index_R8 (X, IA, rc) + use MAPL_SortMod + real(ESMF_KIND_R8), intent(inout) :: X(:) + integer, intent(in) :: IA(:) ! index + integer, optional, intent(out) :: rc + + integer :: i, len + real(ESMF_KIND_R8), allocatable :: XX(:) + + _ASSERT (size(X)==size(IA), 'X and IA (its index) differ in dimension') + len = size (X) + allocate (XX(len)) + XX(:) = X(:) + do i=1, len + X(i) = XX(IA(i)) + enddo + _RETURN(_SUCCESS) + + end subroutine apply_order_index_R8 + + subroutine apply_order_index_I4 (X, IA, rc) + use MAPL_SortMod + integer, intent(inout) :: X(:) + integer, intent(in) :: IA(:) ! index + integer, optional, intent(out) :: rc + + integer :: i, len + integer, allocatable :: XX(:) + + _ASSERT (size(X)==size(IA), 'X and IA (its index) differ in dimension') + len = size (X) + allocate (XX(len)) + XX(:) = X(:) + do i=1, len + X(i) = XX(IA(i)) + enddo + _RETURN(_SUCCESS) + + end subroutine apply_order_index_I4 + function copy_platform_nckeys(a, rc) type(obs_platform) :: copy_platform_nckeys type(obs_platform), intent(in) :: a diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 0a403792e9d6..01bed4e9ba7e 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -225,8 +225,8 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) real(kind=ESMF_KIND_R8), allocatable :: lat_true(:,:) real(kind=ESMF_KIND_R8), allocatable :: time_true(:,:) real(kind=ESMF_KIND_R8), pointer :: arr_lon(:,:) - real(kind=ESMF_KIND_R8), pointer :: arr_lat(:,:) - + real(kind=ESMF_KIND_R8), pointer :: arr_lat(:,:) + integer :: i, j, k integer :: Xdim, Ydim integer :: Xdim_full, Ydim_full @@ -243,19 +243,19 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) integer :: mypet, petcount integer :: nsize, count integer :: mpic - + _UNUSED_DUMMY(unusable) call ESMF_VMGetCurrent(vm,_RC) !! call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) - + Xdim=this%im_world Ydim=this%jm_world count = Xdim * Ydim - + call MAPL_grid_interior(grid, i_1, i_n, j_1, j_n) call MAPL_AllocateShared(arr_lon,[Xdim,Ydim],transroot=.true.,_RC) - call MAPL_AllocateShared(arr_lat,[Xdim,Ydim],transroot=.true.,_RC) + call MAPL_AllocateShared(arr_lat,[Xdim,Ydim],transroot=.true.,_RC) call MAPL_SyncSharedMemory(_RC) if (mapl_am_i_root()) then @@ -271,7 +271,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) do j=this%epoch_index(3), this%epoch_index(4) k=k+1 arr_lon(1:Xdim, k) = lon_true(1:Xdim, j) - arr_lat(1:Xdim, k) = lat_true(1:Xdim, j) + arr_lat(1:Xdim, k) = lat_true(1:Xdim, j) enddo arr_lon=arr_lon*MAPL_DEGREES_TO_RADIANS_R8 arr_lat=arr_lat*MAPL_DEGREES_TO_RADIANS_R8 @@ -280,13 +280,13 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! write(6,*) 'in root' ! write(6,'(11x,100f10.1)') arr_lon(::5,189) end if -! call MPI_Barrier(mpic, status) +! call MPI_Barrier(mpic, status) call MAPL_SyncSharedMemory(_RC) call MAPL_BcastShared (VM, data=arr_lon, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) - call MAPL_BcastShared (VM, data=arr_lat, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) - -! write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) + call MAPL_BcastShared (VM, data=arr_lat, N=count, Root=MAPL_ROOT, RootOnly=.false., _RC) + +! write(6,'(2x,a,2x,i5,4x,100f10.1)') 'PET', mypet, arr_lon(::5,189) ! call MPI_Barrier(mpic, status) call ESMF_GridGetCoord(grid, coordDim=1, localDE=0, & @@ -301,10 +301,10 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) if(MAPL_ShmInitialized) then call MAPL_DeAllocNodeArray(arr_lon,_RC) - call MAPL_DeAllocNodeArray(arr_lat,_RC) + call MAPL_DeAllocNodeArray(arr_lat,_RC) else deallocate(arr_lon) - deallocate(arr_lat) + deallocate(arr_lat) end if ! if (mapl_am_I_root()) then @@ -318,7 +318,7 @@ subroutine add_horz_coordinates_from_file(this, grid, unusable, rc) ! if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then ! write(6,'(2x,a,2x,i10)') 'add_horz_coord: MAPL_AmNodeRoot: mypet=', mypet ! end if - + _RETURN(_SUCCESS) end subroutine add_horz_coordinates_from_file @@ -480,11 +480,8 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%epoch, label=prefix//'Epoch:', default=300, _RC) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'Epoch_init:', default='2006', _RC) - write(6,'(2x,a,100i10)') 'nail 2, nx,ny,im,jm,lm',& - this%nx,this%ny,this%im_world,this%jm_world,this%lm - call lgr%debug(' %a %a', 'CurrTime =', trim(tmp)) - + if ( index(tmp, 'T') /= 0 .OR. index(tmp, '-') /= 0 ) then call ESMF_TimeSet(currTime, timeString=tmp, _RC) else @@ -499,20 +496,6 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc label= prefix// 'obs_file_begin:', _RC) _ASSERT (trim(STR1)/='', 'obs_file_begin missing, critical for data with 5 min interval!') call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) - !!disable using currTime as obsfile_start_time - !!if (trim(STR1)=='') then - !! this%obsfile_start_time = currTime - !! call ESMF_TimeGet(currTime, timestring=STR1, _RC) - !! if (mapl_am_I_root()) then - !! write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) - !! endif - !!else - !! call ESMF_TimeSet(this%obsfile_start_time, timestring=STR1, _RC) - !! if (mapl_am_I_root()) then - !! write(6,105) 'obs_file_begin provided: ', trim(STR1) - !! end if - !!end if - if (mapl_am_I_root()) then write(6,105) 'obs_file_begin provided: ', trim(STR1) @@ -679,6 +662,12 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc this%t_alongtrack(1), this%t_alongtrack(nend)) call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) + call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) + call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) + call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & + this%t_alongtrack(1), this%t_alongtrack(nend)) + call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) + if (jt1==jt2) then _FAIL('Epoch Time is too small, empty swath grid is generated, increase Epoch') endif @@ -1452,11 +1441,11 @@ subroutine get_obs_time(this, grid, obs_time, rc) ! debug type(ESMF_VM) :: vm integer :: mypet, petcount - integer :: mpic + integer :: mpic call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMGet(vm, mpiCommunicator=mpic, localPet=mypet, petCount=petCount, _RC) - + Xdim=this%im_world Ydim=this%jm_world count=Xdim*Ydim @@ -1498,7 +1487,7 @@ subroutine get_obs_time(this, grid, obs_time, rc) call MAPL_DeAllocNodeArray(arr_time,_RC) else deallocate(arr_time) - end if + end if _RETURN(_SUCCESS) end subroutine get_obs_time diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index 8dcc1d7b6c6b..bd832853ceed 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -245,14 +245,14 @@ subroutine get_v1d_netcdf_R8_complete(filename, varname, array, att_name, att_va real(REAL64), intent(inout) :: array(:) character(len=*), optional, intent(in) :: att_name real(REAL64), optional, intent(out) :: att_value - character(len=*), optional, intent(out) :: group_name + character(len=*), optional, intent(out) :: group_name integer, optional, intent(out) :: rc integer :: status, iret integer :: ncid, ncid_grp, ncid_sv - integer :: varid + integer :: varid real(REAL32) :: scale_factor, add_offset - + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) ncid_sv = ncid if(present(group_name)) then @@ -272,7 +272,7 @@ subroutine get_v1d_netcdf_R8_complete(filename, varname, array, att_name, att_va if(present(att_name)) then call check_nc_status(nf90_get_att(ncid, varid, att_name, att_value), _RC) end if - + call check_nc_status(nf90_close(ncid_sv), _RC) _RETURN(_SUCCESS) @@ -287,12 +287,12 @@ subroutine get_att_real_netcdf(filename, varname, att_name, att_value, group_nam character(len=*), intent(in) :: varname character(len=*), intent(in) :: att_name real(REAL64), intent(out) :: att_value - character(len=*), optional, intent(out) :: group_name + character(len=*), optional, intent(out) :: group_name integer, optional, intent(out) :: rc integer :: status integer :: ncid, ncid_grp, ncid_sv - integer :: varid - + integer :: varid + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) ncid_sv = ncid if(present(group_name)) then @@ -307,7 +307,7 @@ subroutine get_att_real_netcdf(filename, varname, att_name, att_value, group_nam _RETURN(_SUCCESS) end subroutine get_att_real_netcdf - + subroutine get_att_char_netcdf(filename, varname, att_name, att_value, group_name, rc) use netcdf implicit none @@ -315,12 +315,12 @@ subroutine get_att_char_netcdf(filename, varname, att_name, att_value, group_nam character(len=*), intent(in) :: varname character(len=*), intent(in) :: att_name character(len=*), intent(out) :: att_value - character(len=*), optional, intent(out) :: group_name + character(len=*), optional, intent(out) :: group_name integer, optional, intent(out) :: rc integer :: status integer :: ncid, ncid_grp, ncid_sv - integer :: varid - + integer :: varid + call check_nc_status(nf90_open(trim(fileName), NF90_NOWRITE, ncid), _RC) ncid_sv = ncid if(present(group_name)) then @@ -335,7 +335,7 @@ subroutine get_att_char_netcdf(filename, varname, att_name, att_value, group_nam _RETURN(_SUCCESS) end subroutine get_att_char_netcdf - + subroutine check_nc_status(status, rc) use netcdf @@ -396,12 +396,12 @@ subroutine time_esmf_2_nc_int(time, tunit, n, rc) call parse_timeunit(tunit, n, time0, dt, _RC) dt = time - time0 -! ! test -! write(6, '(2x,a,2x,a)') 'tunit=', trim(tunit) -! call ESMF_TimeGet(time, timestring=STR1, _RC) -! write(6, '(2x,a,2x,a)') 'time=', trim(STR1) -! call ESMF_TimeGet(time0, timestring=STR1, _RC) -! write(6, '(2x,a,2x,a)') 'time0=', trim(STR1) + !! test + !!write(6, '(2x,a,2x,a)') 'tunit=', trim(tunit) + !!call ESMF_TimeGet(time, timestring=STR1, _RC) + !!write(6, '(2x,a,2x,a)') 'time=', trim(STR1) + !!call ESMF_TimeGet(time0, timestring=STR1, _RC) + !!write(6, '(2x,a,2x,a)') 'time0=', trim(STR1) ! assume unit is second ! @@ -432,7 +432,6 @@ subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) character(len=1) :: c1 integer :: y,m,d,hour,min,sec integer :: isec - type(ESMF_Calendar) :: gregorianCalendar i=index(trim(tunit), 'since') s_time=trim(tunit(i+5:)) @@ -441,12 +440,17 @@ subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) read(s1, '(i4,a1,i2,a1,i2)') y, c1, m, c1, d read(s2, '(i2,a1,i2,a1,i2)') hour, c1, min, c1, sec - _ASSERT(trim(s_unit) == 'seconds', "s_unit /= 'seconds' is not handled") - isec=n + if (trim(s_unit) == 'seconds') then + isec=n + elseif (trim(s_unit) == 'minutes') then + isec=n * 60 + elseif (trim(s_unit) == 'hours') then + isec=n * 3600 + else + _FAIL ('time_unit not implemented') + end if - gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) - call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,& - calendar=gregorianCalendar, _RC) + call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,_RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s=isec, _RC) _RETURN(_SUCCESS) @@ -470,7 +474,6 @@ subroutine parse_timeunit_i8(tunit, n, t0, dt, rc) character(len=1) :: c1 integer :: y,m,d,hour,min,sec integer(ESMF_KIND_I8) :: isec - type(ESMF_Calendar) :: gregorianCalendar i=index(trim(tunit), 'since') s_time=trim(tunit(i+5:)) @@ -482,18 +485,70 @@ subroutine parse_timeunit_i8(tunit, n, t0, dt, rc) ! write(6,*) 'y, c1, m, c1, d', y, c1, m, c1, d ! write(6,*) 'hour, c1, min, c1, sec', hour, c1, min, c1, sec - _ASSERT(trim(s_unit) == 'seconds', "s_unit /= 'seconds' is not handled") - isec=n + if (trim(s_unit) == 'seconds') then + isec=n + elseif (trim(s_unit) == 'minutes') then + isec=n * 60 + elseif (trim(s_unit) == 'hours') then + isec=n * 3600 + else + _FAIL ('time_unit not implemented') + end if - gregorianCalendar = ESMF_CalendarCreate(ESMF_CALKIND_GREGORIAN, name='Gregorian_obs', _RC) - call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,& - calendar=gregorianCalendar, _RC) + call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec, _RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s_i8=isec, _RC) _RETURN(_SUCCESS) end subroutine parse_timeunit_i8 + subroutine diff_two_timeunits (tunit1, tunit2, x, rc) + character(len=*), intent(in) :: tunit1 + character(len=*), intent(in) :: tunit2 + real(ESMF_KIND_R8), intent(out) :: x + integer, intent(out), optional :: rc + + type(ESMF_Time) :: t1_base + type(ESMF_TimeInterval) :: dt1 + type(ESMF_Time) :: t2_base + type(ESMF_TimeInterval) :: dt2 + type(ESMF_TimeInterval) :: deltaT_base + integer(ESMF_KIND_I8) :: n1 + integer(ESMF_KIND_I8) :: n2 + character(len=20) :: s_unit + integer :: i, status, sec + + n1=0; n2=0 + call parse_timeunit (tunit1, n1, t1_base, dt1, _RC) + call parse_timeunit (tunit2, n2, t2_base, dt2, _RC) + deltaT_base = t2_base - t1_base + + i=index(trim(tunit1), 'since') + s_unit=trim(tunit1(1:i-1)) + + !! call ESMF_TimeIntervalGet(deltaT_base, s_r8=x, _RC) + call ESMF_TimeIntervalGet(deltaT_base, s=sec, _RC) + if (trim(s_unit) == 'seconds') then + x = sec + ! pass + elseif (trim(s_unit) == 'minutes') then + x = sec / 60.d0 + elseif (trim(s_unit) == 'hours') then + x = sec /3600.d0 + else + _FAIL ('time_unit not implemented') + end if + + !!write(6,*) 'tunit1=', tunit1 + !!write(6,*) 'tunit2=', tunit2 + !!write(6,*) 'del sec', sec + !!write(6,*) 'del x', x + + _RETURN(ESMF_SUCCESS) + end subroutine diff_two_timeunits + + + subroutine ESMF_time_to_two_integer(time, itime, rc) type(ESMF_Time), intent(in) :: time diff --git a/gridcomps/History/CMakeLists.txt b/gridcomps/History/CMakeLists.txt index 269ae7317758..556360cdd180 100644 --- a/gridcomps/History/CMakeLists.txt +++ b/gridcomps/History/CMakeLists.txt @@ -7,6 +7,8 @@ set (srcs MAPL_HistoryGridComp.F90 MAPL_EpochSwathMod.F90 MAPL_StationSamplerMod.F90 + MAPL_HistoryMaskGeosatMod.F90 + MAPL_HistoryMaskGeosatMod_smod.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.profiler MAPL.griddedio diff --git a/gridcomps/History/MAPL_HistoryCollection.F90 b/gridcomps/History/MAPL_HistoryCollection.F90 index 0bc60881028d..f423b35a21ea 100644 --- a/gridcomps/History/MAPL_HistoryCollection.F90 +++ b/gridcomps/History/MAPL_HistoryCollection.F90 @@ -9,6 +9,7 @@ module MAPL_HistoryCollectionMod use MAPL_VerticalDataMod use MAPL_TimeDataMod use HistoryTrajectoryMod + use MaskSamplerGeosatMod use StationSamplerMod use gFTL_StringStringMap use MAPL_EpochSwathMod @@ -110,6 +111,7 @@ module MAPL_HistoryCollectionMod logical :: timeseries_output = .false. logical :: recycle_track = .false. type(HistoryTrajectory) :: trajectory + type(MaskSamplerGeosat) :: mask_sampler type(StationSampler) :: station_sampler character(len=ESMF_MAXSTR) :: sampler_spec = "" character(len=ESMF_MAXSTR) :: positive diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 9f5329b99ec5..09138f1a467d 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -53,6 +53,7 @@ module MAPL_HistoryGridCompMod use pFIO_ConstantsMod use HistoryTrajectoryMod use StationSamplerMod + use MaskSamplerGeosatMod use MAPL_StringTemplate use regex_module use MAPL_TimeUtilsMod, only: is_valid_time, is_valid_date @@ -901,11 +902,14 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) ! Get an optional file containing a 1-D track for the output call ESMF_ConfigGetDim(cfg, nline, ncol, label=trim(string)//'obs_files:', rc=rc) ! here donot check rc on purpose - if (rc==0) then - if (nline > 0) then - list(n)%timeseries_output = .true. - endif - endif + if (list(n)%sampler_spec == 'trajectory') then + list(n)%timeseries_output = .true. + end if +!! if (rc==0) then +!! if (nline > 0) then +!! list(n)%timeseries_output = .true. +!! endif +!! endif ! Handle "backwards" mode: this is hidden (i.e. not documented) feature @@ -1649,6 +1653,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then call ESMF_TimeIntervalGet(Hsampler%Frequency_epoch, s=sec, _RC) end if + if (list(n)%sampler_spec == 'station' .OR. list(n)%sampler_spec == 'mask') then + sec = MAPL_nsecf(list(n)%frequency) + end if call ESMF_TimeIntervalSet( INTSTATE%STAMPOFFSET(n), S=sec, _RC ) end do @@ -2415,6 +2422,9 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) list(n)%trajectory = HistoryTrajectory(cfg,string,clock,_RC) call list(n)%trajectory%initialize(items=list(n)%items,bundle=list(n)%bundle,timeinfo=list(n)%timeInfo,vdata=list(n)%vdata,_RC) IntState%stampoffset(n) = list(n)%trajectory%epoch_frequency + elseif (list(n)%sampler_spec == 'mask') then + list(n)%mask_sampler = MaskSamplerGeosat(cfg,string,clock,_RC) + call list(n)%mask_sampler%initialize(items=list(n)%items,bundle=list(n)%bundle,timeinfo=list(n)%timeInfo,vdata=list(n)%vdata,_RC) elseif (list(n)%sampler_spec == 'station') then list(n)%station_sampler = StationSampler (trim(list(n)%stationIdFile), nskip_line=list(n)%stationSkipLine, _RC) call list(n)%station_sampler%add_metadata_route_handle(list(n)%bundle,list(n)%timeInfo,vdata=list(n)%vdata,_RC) @@ -3386,6 +3396,10 @@ subroutine Run ( gc, import, export, clock, rc ) Writing(n) = .false. else if (list(n)%timeseries_output) then Writing(n) = ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) + !! ygyu delete it + !! mask: use frequency + !! else if (list(n)%sampler_spec == 'mask') then + !! Writing(n) = ESMF_AlarmIsRinging ( list(n)%mask_sampler%alarm ) else if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then Writing(n) = ESMF_AlarmIsRinging ( Hsampler%alarm ) else @@ -3533,6 +3547,15 @@ subroutine Run ( gc, import, export, clock, rc ) list(n)%currentFile = filename(n) list(n)%unit = -1 end if + elseif (list(n)%sampler_spec == 'mask') then + if (list(n)%unit.eq.0) then + call lgr%debug('%a %a',& + "Mask_data output to new file:",trim(filename(n))) + call list(n)%mask_sampler%close_file_handle(_RC) + call list(n)%mask_sampler%create_file_handle(filename(n),_RC) + list(n)%currentFile = filename(n) + list(n)%unit = -1 + end if else if( list(n)%unit.eq.0 ) then if (list(n)%format == 'CFIO') then @@ -3614,7 +3637,9 @@ subroutine Run ( gc, import, export, clock, rc ) state_out = INTSTATE%GIM(n) end if - if (.not.list(n)%timeseries_output .AND. list(n)%sampler_spec /= 'station') then + if (.not.list(n)%timeseries_output .AND. & + list(n)%sampler_spec /= 'station' .AND. & + list(n)%sampler_spec /= 'mask') then IOTYPE: if (list(n)%unit < 0) then ! CFIO call list(n)%mGriddedIO%bundlepost(list(n)%currentFile,oClients=o_Clients,_RC) else @@ -3641,6 +3666,9 @@ subroutine Run ( gc, import, export, clock, rc ) if (list(n)%sampler_spec == 'station') then call ESMF_ClockGet(clock,currTime=current_time,_RC) call list(n)%station_sampler%append_file(current_time,_RC) + elseif (list(n)%sampler_spec == 'mask') then + call ESMF_ClockGet(clock,currTime=current_time,_RC) + call list(n)%mask_sampler%append_file(current_time,_RC) endif endif OUTTIME @@ -3708,6 +3736,17 @@ subroutine Run ( gc, import, export, clock, rc ) call list(n)%trajectory%close_file_handle(_RC) call list(n)%trajectory%destroy_rh_regen_LS (_RC) end if + !! elseif (list(n)%sampler_spec == 'mask') then + + !! ygyu take action + ! output to files + + ! call list(n)%mask_sampler%find_mask(_RC) + ! if( ESMF_AlarmIsRinging ( list(n)%mask_sampler%alarm ) ) then + ! call list(n)%mask_sampler%append_file(current_time,_RC) + ! call list(n)%mask_sampler%close_file_handle(_RC) + ! end if + end if if( Writing(n) .and. list(n)%unit < 0) then @@ -5262,6 +5301,8 @@ function get_acc_offset(current_time,ref_time,rc) result(acc_offset) ! __ for each collection: find union fields, write to collection.rcx ! __ note: this subroutine is called by MPI root only ! + ! __ note: this subroutine is called by MPI root only + ! subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) use MAPL_scan_pattern_in_file use MAPL_ObsUtilMod, only : obs_platform, union_platform @@ -5395,15 +5436,12 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) nseg_ub=0 do while (ios == 0) read (unitr, '(A)' ) line - con = .not.(adjustl(trim(line))=='::') - if (con) then - ngeoval = ngeoval + 1 - call split_string_by_space (line, length_mx, mxseg, & - nseg, str_piece, status) - nseg_ub = max(nseg_ub, nseg) - else - exit - endif + con = (adjustl(trim(line))=='::') + if (con) exit + ngeoval = ngeoval + 1 + call split_string_by_space (line, length_mx, mxseg, & + nseg, str_piece, status) + nseg_ub = max(nseg_ub, nseg) enddo PLFS(k)%ngeoval = ngeoval PLFS(k)%nentry_name = nseg_ub @@ -5493,13 +5531,14 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) allocate (str_piece(mxseg)) i = index(line2, ':') line = adjustl ( line2(i+1:) ) - write(6,*) 'line for obsplatforms=', trim(line) call split_string_by_space (line, length_mx, mxseg, & nplatform, str_piece, status) + !! to do: add debug + !!write(6,*) 'line for obsplatforms=', trim(line) + !!write(6,*) 'split string, nplatform=', nplatform + !!write(6,*) 'nplf=', nplf - write(6,*) 'split string, nplatform=', nplatform - write(6,*) 'nplf=', nplf !!write(6,*) 'str_piece=', str_piece(1:nplatform) !!do j=1, nplf !! write(6,*) 'PLFS(j)%name=', trim( PLFS(j)%name ) @@ -5554,8 +5593,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) write(unitw,'(a,/)') '::' write(unitw,'(a)') trim(string)//'obs_files: # table start from next line' - - write(6,*) 'nplatform', nplatform + !! TODO: add debug + !! write(6,*) 'nplatform', nplatform do i2=1, nplatform k=map(i2) write(unitw, '(a)') trim(adjustl(PLFS(k)%file_name_template)) diff --git a/gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 b/gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 new file mode 100644 index 000000000000..69a83a0ac979 --- /dev/null +++ b/gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 @@ -0,0 +1,179 @@ +module MaskSamplerGeosatMod + use ESMF + use MAPL_ErrorHandlingMod + use MAPL_KeywordEnforcerMod + use LocStreamFactoryMod + use MAPL_LocstreamRegridderMod + use MAPL_FileMetadataUtilsMod + use pFIO + use MAPL_GriddedIOItemMod + use MAPL_GriddedIOItemVectorMod + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_BaseMod + use MAPL_CommsMod + use MAPL_SortMod + use MAPL_NetCDF + use MAPL_StringTemplate + use Plain_netCDF_Time + use MAPL_ObsUtilMod + use MPI + use pFIO_FileMetadataMod, only : FileMetadata + use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter + use, intrinsic :: iso_fortran_env, only: REAL32 + use, intrinsic :: iso_fortran_env, only: REAL64 + use pflogger, only: Logger, logging + implicit none + + private + + public :: MaskSamplerGeosat + type :: MaskSamplerGeosat + private + ! character(len=:), allocatable :: grid_file_name + character(len=ESMF_MAXSTR) :: grid_file_name + !-- ygyu we donot need LS + ! + ! we need on each PET + ! npt_mask, index_mask(1:2,npt_mask)=[i,j] + ! + integer :: npt_mask + integer :: npt_mask_tot + integer, allocatable :: index_mask(:,:) + ! + type(ESMF_FieldBundle) :: bundle + type(ESMF_FieldBundle) :: output_bundle + ! type(ESMF_FieldBundle) :: acc_bundle + ! type(ESMF_Field) :: fieldA + ! type(ESMF_Field) :: fieldB + + type(GriddedIOitemVector) :: items + type(VerticalData) :: vdata + logical :: do_vertical_regrid + character(len=ESMF_MAXSTR) :: ofile + type(TimeData) :: time_info + type(ESMF_Clock) :: clock + type(ESMF_Alarm), public :: alarm + type(ESMF_Time) :: RingTime + type(ESMF_TimeInterval) :: epoch_frequency + type(FileMetadata) :: metadata + type(NetCDF4_FileFormatter) :: formatter + + + integer :: nobs_type + integer :: nobs + integer :: obs_written + + character(len=ESMF_MAXSTR) :: index_name_x + character(len=ESMF_MAXSTR) :: index_name_y + character(len=ESMF_MAXSTR) :: index_name_location + character(len=ESMF_MAXSTR) :: index_name_lon + character(len=ESMF_MAXSTR) :: index_name_lat + character(len=ESMF_MAXSTR) :: index_name_loc + character(len=ESMF_MAXSTR) :: var_name_time + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_x + character(len=ESMF_MAXSTR) :: var_name_y + character(len=ESMF_MAXSTR) :: var_name_proj + character(len=ESMF_MAXSTR) :: att_name_proj + + integer :: xdim_true + integer :: ydim_true + integer :: thin_factor + + integer :: epoch ! unit: second + integer(kind=ESMF_KIND_I8) :: epoch_index(2) + real(kind=REAL64), allocatable :: lons(:) + real(kind=REAL64), allocatable :: lats(:) + integer, allocatable :: recvcounts(:) + integer, allocatable :: displs(:) + + real(kind=ESMF_KIND_R8), pointer:: obsTime(:) + real(kind=ESMF_KIND_R8), allocatable:: t_alongtrack(:) + integer :: nobs_dur + integer :: nobs_dur_sum + type(ESMF_Time) :: obsfile_start_time ! user specify + type(ESMF_Time) :: obsfile_end_time + type(ESMF_TimeInterval) :: obsfile_interval + integer :: obsfile_Ts_index ! for epoch + integer :: obsfile_Te_index + logical :: is_valid + contains + procedure :: initialize + procedure :: add_metadata + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file => regrid_accumulate_append_file +! procedure :: create_new_bundle + procedure :: create_grid => create_Geosat_grid_find_mask + procedure :: compute_time_for_current + end type MaskSamplerGeosat + + interface MaskSamplerGeosat + module procedure MaskSamplerGeosat_from_config + end interface MaskSamplerGeosat + + + interface + module function MaskSamplerGeosat_from_config(config,string,clock,rc) result(mask) + type(MaskSamplerGeosat) :: mask + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: string + type(ESMF_Clock), intent(in) :: clock + integer, optional, intent(out) :: rc + end function MaskSamplerGeosat_from_config + + module subroutine initialize(this,items,bundle,timeInfo,vdata,reinitialize,rc) + class(MaskSamplerGeosat), intent(inout) :: this + type(GriddedIOitemVector), optional, intent(inout) :: items + type(ESMF_FieldBundle), optional, intent(inout) :: bundle + type(TimeData), optional, intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + logical, optional, intent(in) :: reinitialize + integer, optional, intent(out) :: rc + end subroutine initialize + + module subroutine create_Geosat_grid_find_mask(this, rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine create_Geosat_grid_find_mask + +!! module function create_new_bundle(this,rc) result(new_bundle) +!! class(MaskSamplerGeosat), intent(inout) :: this +!! type(ESMF_FieldBundle) :: new_bundle +!! integer, optional, intent(out) :: rc +!! end function create_new_bundle + + !! module subroutine add_metadata(this,currTime,rc) + module subroutine add_metadata(this,rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine add_metadata + + module subroutine create_file_handle(this,filename,rc) + class(MaskSamplerGeosat), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, optional, intent(out) :: rc + end subroutine create_file_handle + + module subroutine close_file_handle(this,rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine close_file_handle + + module subroutine regrid_accumulate_append_file(this,current_time,rc) + class(MaskSamplerGeosat), intent(inout) :: this + type(ESMF_Time), intent(inout) :: current_time + integer, optional, intent(out) :: rc + end subroutine regrid_accumulate_append_file + + module function compute_time_for_current(this,current_time,rc) result(rtime) + class(MaskSamplerGeosat), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + real(kind=ESMF_KIND_R8) :: rtime + end function compute_time_for_current + + end interface +end module MaskSamplerGeosatMod diff --git a/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 b/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 new file mode 100644 index 000000000000..d48b52f0c029 --- /dev/null +++ b/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 @@ -0,0 +1,797 @@ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +submodule (MaskSamplerGeosatMod) MaskSamplerGeosat_implement + implicit none +contains + + module procedure MaskSamplerGeosat_from_config + use BinIOMod + use pflogger, only : Logger, logging + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: epoch_frequency + type(ESMF_TimeInterval) :: obs_time_span + integer :: time_integer, second + integer :: status + character(len=ESMF_MAXSTR) :: STR1, line + character(len=ESMF_MAXSTR) :: symd, shms + integer :: nline, col + integer, allocatable :: ncol(:) + character(len=ESMF_MAXSTR), allocatable :: word(:) + integer :: nobs, head, jvar + logical :: tend + integer :: i, j, k, M + integer :: count + integer :: unitr, unitw + type(Logger), pointer :: lgr + + mask%clock=clock + mask%grid_file_name='' + call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) + if (mapl_am_I_root()) write(6,*) 'string', string + + + call ESMF_ConfigGetAttribute(config, value=mask%grid_file_name,label=trim(string)//'obs_files:', default="", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%index_name_x, label=trim(string)//'index_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%index_name_y, label=trim(string)//'index_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%var_name_x, label=trim(string)//'var_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%var_name_y, label=trim(string)//'var_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%var_name_proj, label=trim(string)//'var_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%att_name_proj, label=trim(string)//'att_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%thin_factor, label=trim(string)//'thin_factor:', default=-1, _RC) + + + if (mapl_am_I_root()) write(6,*) 'thin_factor:', mask%thin_factor + call ESMF_ConfigGetAttribute(config, value=STR1, label=trim(string)//'obs_file_begin:', default="", _RC) + if (trim(STR1)=='') then + mask%obsfile_start_time = currTime + call ESMF_TimeGet(currTime, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) + endif + else + call ESMF_TimeSet(mask%obsfile_start_time, STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin provided: ', trim(STR1) + end if + end if + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_end:', _RC) + if (trim(STR1)=='') then + call ESMF_TimeIntervalSet(obs_time_span, d=14, _RC) + mask%obsfile_end_time = mask%obsfile_start_time + obs_time_span + call ESMF_TimeGet(mask%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end missing, default = begin+14D:', trim(STR1) + endif + else + call ESMF_TimeSet(mask%obsfile_end_time, STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end provided:', trim(STR1) + end if + end if + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_interval:', _RC) + _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') + if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) + + + i= index( trim(STR1), ' ' ) + if (i>0) then + symd=STR1(1:i-1) + shms=STR1(i+1:) + else + symd='' + shms=trim(STR1) + endif + call convert_twostring_2_esmfinterval (symd, shms, mask%obsfile_interval, _RC) + + mask%is_valid = .true. + + _RETURN(_SUCCESS) + +105 format (1x,a,2x,a) +106 format (1x,a,2x,i8) + end procedure MaskSamplerGeosat_from_config + + + ! + !-- integrate both initialize and reinitialize + ! + module procedure initialize + integer :: status + type(ESMF_Grid) :: grid + type(variable) :: v + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_Time) :: currTime + integer :: k + + if (.not. present(reinitialize)) then + if(present(bundle)) this%bundle=bundle + if(present(items)) this%items=items + if(present(timeInfo)) this%time_info=timeInfo + if (present(vdata)) then + this%vdata=vdata + else + this%vdata=VerticalData(_RC) + end if + end if + + this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) + + this%ofile = '' + this%obs_written = 0 + + call this%create_grid(_RC) + call this%add_metadata(_RC) + + _RETURN(_SUCCESS) + + end procedure initialize + + + module procedure create_Geosat_grid_find_mask + use pflogger, only: Logger, logging + implicit none + type(Logger), pointer :: lgr + real(ESMF_KIND_R8), pointer :: ptAT(:) + type(ESMF_routehandle) :: RH + type(ESMF_Grid) :: grid + integer :: mypet, npes + integer :: iroot, rootpet, ierr + type (ESMF_LocStream) :: LS_rt + type (ESMF_LocStream) :: LS_ds + type (LocStreamFactory):: locstream_factory + type (ESMF_Field) :: fieldA + type (ESMF_Field) :: fieldB + + integer :: i, j, k, L + integer :: n1, n2 + integer :: nx, ny, nx_sum + integer :: nlon, nlat + integer :: arr(1) + integer :: len + + integer :: IM, JM, LM, COUNTS(3) + type(ESMF_DistGrid) :: distGrid + type(ESMF_DElayout) :: layout + type(ESMF_VM) :: VM + integer :: myid + integer :: ndes + integer :: dimCount + integer, allocatable :: II(:) + integer, allocatable :: JJ(:) + real(REAL64), allocatable :: obs_lons(:) + real(REAL64), allocatable :: obs_lats(:) + integer :: mpic + + type (ESMF_Field) :: fieldI4 + type(ESMF_routehandle) :: RH_halo + type(ESMF_Field) :: src_field,dst_field,acc_field + integer :: useableHalo_width + integer :: rank + integer :: eLB(2), eUB(2) + integer :: cLB(2), cUB(2) + integer :: tLB(2), tUB(2) + integer :: ecount(2) + integer :: ccount(2) + integer :: tcount(2) + integer(ESMF_KIND_I4), pointer :: farrayPtr(:,:) + real(ESMF_KIND_R8), pointer :: ptA(:) + real(ESMF_KIND_R8), pointer :: ptB(:) + + character(len=50) :: filename + integer :: unit + integer :: ix, jx + integer :: i_1, i_n, j_1, j_n + real(REAL64), pointer :: x(:) + real(REAL64), pointer :: y(:) + real(REAL64) :: lambda0_deg, lambda0 + real(REAL64) :: x0, y0 + real(REAL64) :: lon0, lat0 + real(REAL64) :: lam_sat + integer :: mask0 + character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att + integer :: Xdim_true, Ydim_true + integer :: Xdim_red, Ydim_red + real(REAL64), allocatable :: lons(:), lats(:) + real(REAL64), allocatable :: lons_ds(:), lats_ds(:) + integer, allocatable :: mask(:,:) + + real(ESMF_kind_R8), pointer :: lons_ptr(:,:), lats_ptr(:,:) + integer :: nsend + integer, allocatable :: recvcounts_loc(:) + integer, allocatable :: displs_loc(:) + integer :: status + + lgr => logging%get_logger('HISTORY.sampler') + + ! Metacode: + ! read ABI grid into LS_rt + ! gen LS_ds with CS background grid + ! find mask points on each PET with halo + ! prepare recvcounts + displs for gatherv + ! + + if (mapl_am_i_root()) then + ! __s1. SAT file + ! + fn = this%grid_file_name + key_x = this%var_name_x + key_y = this%var_name_y + key_p = this%var_name_proj + key_p_att = this%att_name_proj + call get_ncfile_dimension(fn,nlon=n1,nlat=n2,key_lon=key_x,key_lat=key_y,_RC) + ! + ! use thin_factor to reduce regridding matrix size + ! + xdim_true = n1 + ydim_true = n2 + xdim_red = n1 / this%thin_factor + ydim_red = n2 / this%thin_factor + allocate (x (xdim_true) ) + allocate (y (xdim_true) ) + + call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) + call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) + call get_att_real_netcdf (fn, key_p, key_p_att, lambda0_deg, _RC) + lam_sat = lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + + nx=0 + do i=1, xdim_red + do j=1, ydim_red + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) + call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) + if (mask0 > 0) then + nx=nx+1 + end if + end do + end do + allocate (lons(nx), lats(nx)) + nx = 0 + do i=1, xdim_red + do j=1, ydim_red + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) + call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) + if (mask0 > 0) then + nx=nx+1 + lons(nx) = lon0 + lats(nx) = lat0 + end if + end do + end do + arr(1)=nx + else + allocate(lons(0),lats(0),_STAT) + arr(1)=0 + endif + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petcount=npes, localpet=mypet, _RC) + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx, & + count=1, reduceflag=ESMF_REDUCE_SUM, _RC) + this%nobs = nx + if (mapl_am_I_root()) write(6,*) 'nobs tot :', nx + + if ( nx == 0 ) then + this%is_valid = .false. + _RETURN(ESMF_SUCCESS) + ! + ! no valid obs points are found + ! + end if + + + ! __ s2. set distributed LS + ! + locstream_factory = LocStreamFactory(lons,lats,_RC) + LS_rt = locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + LS_ds = locstream_factory%create_locstream(grid=grid,_RC) + + fieldA = ESMF_FieldCreate (LS_rt, name='A', typekind=ESMF_TYPEKIND_R8, _RC) + fieldB = ESMF_FieldCreate (LS_ds, name='B', typekind=ESMF_TYPEKIND_R8, _RC) + + call ESMF_FieldGet( fieldA, localDE=0, farrayPtr=ptA) + call ESMF_FieldGet( fieldB, localDE=0, farrayPtr=ptB) + if (mypet == 0) then + ptA(:) = lons(:) + end if + call ESMF_FieldRedistStore (fieldA, fieldB, RH, _RC) + call ESMF_FieldRedist (fieldA, fieldB, RH, _RC) + lons_ds = ptB + + if (mypet == 0) then + ptA(:) = lats(:) + end if + call ESMF_FieldRedist (fieldA, fieldB, RH, _RC) + lats_ds = ptB + + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + call ESMF_FieldDestroy(fieldA,nogarbage=.true.,_RC) + call ESMF_FieldDestroy(fieldB,nogarbage=.true.,_RC) + call ESMF_VMBarrier (vm, _RC) + + !!- debug + !! write(6,'(2x,a,i5,100f10.1)') 'lons_ds pet=', mypet, lons_ds(::1000) + !! write(6,'(2x,a,i5,100f10.1)') 'lats_ds pet=', mypet, lats_ds(::2000) + + + ! __ s3. find n.n. CS pts for LS_ds (halo) + ! + obs_lons = lons_ds + obs_lats = lats_ds + nx = size ( lons_ds ) + allocate ( II(nx), JJ(nx) ) + call MPI_Barrier(mpic, status) + call MAPL_GetHorzIJIndex(nx,II,JJ,lonR8=obs_lons,latR8=obs_lats,grid=grid,_RC) + call ESMF_VMBarrier (vm, _RC) + + !! write(6,*) 'nx', nx + !! do i=1,nx,20 + !! write(6,'(2x,a,i5,i10,2f12.2,10i5)') 'pet,i,lon,lat,II,JJ=', mypet,i,& + !! obs_lons(i),obs_lats(i),II(i),JJ(i) + !! end do + + ! + ! __ halo for mask + ! + call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, _RC) + IM= COUNTS(1) + JM= COUNTS(2) + LM= COUNTS(3) + useableHalo_width = 1 + fieldI4 = ESMF_FieldCreate (grid, ESMF_TYPEKIND_I4, & + totalLwidth=[useableHalo_width,useableHalo_width],& + totalUwidth=[useableHalo_width,useableHalo_width], _RC) + call ESMF_FieldGetBounds (fieldI4, & + exclusiveLBound=eLB, exclusiveUBound=eUB, exclusiveCount=ecount, & + totalLBound=tLB, totalUBound=tUB, totalCount=tcount, & + computationalLBound=cLB, computationalUBound=cUB, computationalCount=ccount, & + _RC) + call ESMF_FieldGet (fieldI4, farrayPtr=farrayPtr, _RC) + farrayPtr(:,:) = 0 + do i=1, nx + if ( II(i)>0 .AND. JJ(i)>0 ) then + farrayPtr( II(i), JJ(i) ) = 1 + endif + enddo + +! debug +! write(6,'(2x,a,2x,i5)') 'pet=', mypet +! do j=tUB(2), tLB(2), -1 +! write(6, '(2x,100i5)') farrayPtr(tLB(1):tUB(1), j) +! end do + + call ESMF_FieldHaloStore (fieldI4, routehandle=RH_halo, _RC) + call ESMF_FieldHalo (fieldI4, routehandle=RH_halo, _RC) + call ESMF_VMBarrier (vm, _RC) + +! write(filename, '(i5)') mypet +! filename='t.'//trim(adjustl(filename)) +! open(newunit=unit, file=trim(filename), status='unknown', _IOSTAT) +! write(6,'(2x,a,2x,5i20)') 'pet,unit', mypet, unit +! write(unit,'(2x,a,2x,i5)') 'AF pet=', mypet +! do j=tUB(2), tLB(2), -1 +! write(unit, '(2x,100i5)') farrayPtr(tLB(1):tUB(1), j) +! end do + + k=0 + do i=eLB(1), eUB(1) + do j=eLB(2), eUB(2) + if ( farrayPtr(i,j)==0 .AND. ( & + farrayPtr(i-1,j)==1 .OR. & + farrayPtr(i+1,j)==1 .OR. & + farrayPtr(i,j-1)==1 .OR. & + farrayPtr(i,j+1)==1 ) ) then + farrayPtr(i,j) = -1 + end if + if (farrayPtr(i,j)/=0) k=k+1 + end do + end do + allocate( mask(IM, JM)) + mask(1:IM, 1:JM) = abs(farrayPtr(1:IM, 1:JM)) + + this%npt_mask = k + allocate( this%index_mask(2,k) ) + arr(1)=k + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=this%npt_mask_tot, & + count=1, reduceflag=ESMF_REDUCE_SUM, _RC) + + k=0 + do i=1, IM + do j=1, JM + if ( mask(i,j)==1 ) then + k=k+1 + this%index_mask(1,k) = i + this%index_mask(2,k) = j + end if + end do + end do + +! ! +! ! -- test and print mask locations +! ! +! write(unit,'(2x,a,2x,i5)') 'connect pet=', mypet +! do j=tUB(2), tLB(2), -1 +! write(unit, '(2x,100i5)') farrayPtr(tLB(1):tUB(1), j) +! end do +! write(unit,'(2x,a,2x,i5)') 'mask pet=', mypet +! do j=eUB(2), eLB(2), -1 +! write(unit, '(2x,100i5)') mask(eLB(1):eUB(1), j) +! end do +! +! write(6,'(2x,a,2x,7i10)') 'this%npt_mask, this%npt_mask_tot', this%npt_mask, this%npt_mask_tot +! write(6,'(2x,a,2x,7i10)') 'this%index_mask(1,1:N)', this%index_mask(1,::5) +! write(6,'(2x,a,2x,7i10)') 'this%index_mask(2,1:N)', this%index_mask(2,::5) +! +! close(unit) +! + + ! FINISH: I have what I need + ! Fixed: npt_mask + index_mask + ! I have index on each PET, + ! The rest is station sampler, except + ! regridding is replaced by + ! - selecting masked data on PET + ! - mpi_gatherV + ! + + + ! __ s4.1 find this%lons/lats on root for NC output + ! + call ESMF_GridGetCoord (grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lons_ptr, _RC) + call ESMF_GridGetCoord (grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lats_ptr, _RC) + deallocate (lons, lats) + allocate (lons(this%npt_mask), lats(this%npt_mask)) + do i=1, this%npt_mask + ix=this%index_mask(1,i) + jx=this%index_mask(2,i) + lons(i) = lons_ptr (ix, jx) + lats(i) = lats_ptr (ix, jx) + end do + + !if (mapl_am_i_root()) then + ! write(6,'(2x,10f8.1)') lons(::5) + ! write(6,'(2x,10f8.1)') lats(::5) + ! print*, 'end lons/lats' + !end if + + iroot=0 + if (mapl_am_i_root()) then + allocate (this%lons(this%npt_mask_tot), this%lats(this%npt_mask_tot)) + else + allocate (this%lons(0), this%lats(0)) + end if + + + ! __ s4.2 find this%recvcounts / this%displs + ! + allocate( this%recvcounts(npes), this%displs(npes) ) + allocate( recvcounts_loc(npes), displs_loc(npes) ) + recvcounts_loc(:)=1 + displs_loc(1)=0 + do i=2, npes + displs_loc(i) = displs_loc(i-1) + recvcounts_loc(i-1) + end do + call MPI_gatherv ( this%npt_mask, 1, MPI_INTEGER, & + this%recvcounts, recvcounts_loc, displs_loc, MPI_INTEGER,& + iroot, mpic, ierr ) + if (.not. mapl_am_i_root()) then + this%recvcounts(:) = 0 + end if + this%displs(1)=0 + do i=2, npes + this%displs(i) = this%displs(i-1) + this%recvcounts(i-1) + end do + + + ! __ s4.3 gatherv lons/lats + ! + nsend=this%npt_mask + call MPI_gatherv ( lons, nsend, MPI_REAL8, & + this%lons, this%recvcounts, this%displs, MPI_REAL8,& + iroot, mpic, ierr ) + call MPI_gatherv ( lats, nsend, MPI_REAL8, & + this%lats, this%recvcounts, this%displs, MPI_REAL8,& + iroot, mpic, ierr ) + + _RETURN(_SUCCESS) + end procedure create_Geosat_grid_find_mask + + +module procedure add_metadata + type(variable) :: v + type(ESMF_Field) :: field + integer :: fieldCount + integer :: field_rank + integer :: nstation + logical :: is_present + integer :: ub(ESMF_MAXDIM) + integer :: lb(ESMF_MAXDIM) + logical :: do_vertical_regrid + integer :: status + integer :: i + + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims + character(len=40) :: datetime_units + + !__ 1. metadata add_dimension, + ! add_variable for time, latlon, mask_points + ! + call this%vdata%append_vertical_metadata(this%metadata,this%bundle,_RC) ! specify lev in fmd + call this%time_info%add_time_to_metadata(this%metadata,_RC) + call this%metadata%add_dimension('mask_index', this%npt_mask_tot) + + v = Variable(type=pFIO_REAL64, dimensions='mask_index') + call v%add_attribute('long_name','longitude') + call v%add_attribute('unit','degree_east') + call this%metadata%add_variable('longitude',v) + + v = Variable(type=pFIO_REAL64, dimensions='mask_index') + call v%add_attribute('long_name','latitude') + call v%add_attribute('unit','degree_north') + call this%metadata%add_variable('latitude',v) + + ! To be added when values are available + !v = Variable(type=pFIO_INT32, dimensions='mask_index') + !call v%add_attribute('long_name','The Cubed Sphere Global Face ID') + !call this%metadata%add_variable('mask_CS_Face_ID',v) + ! + !v = Variable(type=pFIO_INT32, dimensions='mask_index') + !call v%add_attribute('long_name','The Cubed Sphere Global Index I') + !call this%metadata%add_variable('mask_CS_global_index_I',v) + ! + !v = Variable(type=pFIO_INT32, dimensions='mask_index') + !call v%add_attribute('long_name','The Cubed Sphere Global Index J') + !call this%metadata%add_variable('mask_CS_global_index_J',v) + + + !__ 2. filemetadata: extract field from bundle, add_variable to metadata + ! + call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + var_name=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(this%bundle,var_name,field=field,_RC) + call ESMF_FieldGet(field,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) + else + long_name = var_name + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) + else + units = 'unknown' + endif + if (field_rank==2) then + vdims = "mask_index,time" + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[this%npt_mask_tot,1]) + else if (field_rank==3) then + vdims = "lev,mask_index,time" + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + end if + call v%add_attribute('units', trim(units)) + call v%add_attribute('long_name', trim(long_name)) + call v%add_attribute('missing_value', MAPL_UNDEF) + call v%add_attribute('_FillValue', MAPL_UNDEF) + call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) + call this%metadata%add_variable(trim(var_name),v,_RC) + end do + deallocate (fieldNameList) + + _RETURN(_SUCCESS) + end procedure add_metadata + + + module procedure regrid_accumulate_append_file + ! + implicit none + integer :: status + integer :: fieldCount + integer :: ub(1), lb(1) + type(ESMF_Field) :: src_field,dst_field + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(kind=REAL32), allocatable :: p_dst_3d(:),p_dst_2d(:) + real(kind=REAL32), allocatable :: p_dst_3d_full(:),p_dst_2d_full(:) + real(kind=REAL32), allocatable :: arr(:,:) + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: xname + real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i, j, k, rank + integer :: nx, nz + integer :: ix, iy, m + integer :: mypet, npes, nsend + integer :: iroot, ierr + integer :: mpic + integer, allocatable :: recvcounts_3d(:) + integer, allocatable :: displs_3d(:) + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_VM) :: vm + + this%obs_written=this%obs_written+1 + + ! -- fixed for all fields + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petcount=npes, localpet=mypet, _RC) + iroot=0 + nx = this%npt_mask + nz = this%vdata%lm + allocate(p_dst_2d (nx)) + allocate(p_dst_3d (nx * nz)) + if (mapl_am_i_root()) then + allocate ( p_dst_2d_full (this%npt_mask_tot) ) + allocate ( p_dst_3d_full (this%npt_mask_tot * nz) ) + else + allocate ( p_dst_2d_full (0) ) + allocate ( p_dst_3d_full (0) ) + end if + allocate( recvcounts_3d(npes), displs_3d(npes) ) + recvcounts_3d(:) = nz * this%recvcounts(:) + displs_3d(:) = nz * this%displs(:) + + + !__ 1. put_var: time variable + ! + allocate( rtimes(1) ) + rtimes(1) = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file + if (mapl_am_i_root()) then + call this%formatter%put_var('time',rtimes(1:1),& + start=[this%obs_written],count=[1],_RC) + end if + + + !__ 2. put_var: ungridded_dim from src to dst [use index_mask] + ! + ! Currently mask only pickup values + ! It does not support vertical regridding + ! + !if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + ! call this%vdata%setup_eta_to_pressure(_RC) + !endif + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + do j=1, nx + ix = this%index_mask(1,j) + iy = this%index_mask(2,j) + p_dst_2d(j) = p_src_2d(ix, iy) + end do + call MPI_Barrier(mpic, status) + nsend = nx + call MPI_gatherv ( p_dst_2d, nsend, MPI_REAL, & + p_dst_2d_full, this%recvcounts, this%displs, MPI_REAL,& + iroot, mpic, ierr ) + if (mapl_am_i_root()) then + call this%formatter%put_var(item%xname,p_dst_2d_full,& + start=[1,this%obs_written],count=[this%npt_mask_tot,1],_RC) + end if + else if (rank==3) then + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + _ASSERT (this%vdata%lm == (ub(1)-lb(1)+1), 'vertical level is different from CS grid') + m=0 + do j=1, nx + ix = this%index_mask(1,j) + iy = this%index_mask(2,j) + do k= lb(1), ub(1) + m = m + 1 + p_dst_3d(m) = p_src_3d(ix, iy, k) + end do + end do + call MPI_Barrier(mpic, status) + !! write(6,'(2x,a,2x,i5,3x,10f8.1)') 'pet, p_dst_3d(j)', mypet, p_dst_3d(::10) + nsend = nx * nz + call MPI_gatherv ( p_dst_3d, nsend, MPI_REAL, & + p_dst_3d_full, recvcounts_3d, displs_3d, MPI_REAL,& + iroot, mpic, ierr ) + if (mapl_am_i_root()) then + allocate(arr(nz, this%npt_mask_tot)) + arr=reshape(p_dst_3d_full,[nz,this%npt_mask_tot],order=[1,2]) + call this%formatter%put_var(item%xname,arr,& + start=[1,1,this%obs_written],count=[nz,this%npt_mask_tot,1],_RC) + !note: lev,station,time + deallocate(arr) + end if + else + _FAIL('grid2LS regridder: rank > 3 not implemented') + end if + end if + + call iter%next() + end do + + _RETURN(_SUCCESS) + end procedure regrid_accumulate_append_file + + + + module procedure create_file_handle + type(variable) :: v + integer :: status, j + + this%ofile = trim(filename) + v = this%time_info%define_time_variable(_RC) + call this%metadata%modify_variable('time',v,_RC) + this%obs_written = 0 + + if (.not. mapl_am_I_root()) then + _RETURN(_SUCCESS) + end if + + call this%formatter%create(trim(filename),_RC) + call this%formatter%write(this%metadata,_RC) + + call this%formatter%put_var('longitude',this%lons,_RC) + call this%formatter%put_var('latitude',this%lats,_RC) +! call this%formatter%put_var('mask_id',this%mask_id,_RC) +! call this%formatter%put_var('mask_name',this%mask_name,_RC) + + _RETURN(_SUCCESS) + end procedure create_file_handle + + + module procedure close_file_handle + integer :: status + if (trim(this%ofile) /= '') then + if (mapl_am_i_root()) then + call this%formatter%close(_RC) + end if + end if + _RETURN(_SUCCESS) + end procedure close_file_handle + + + module procedure compute_time_for_current + use MAPL_NetCDF, only : convert_NetCDF_DateTime_to_ESMF + integer :: status + type(ESMF_TimeInterval) :: t_interval + class(Variable), pointer :: var + type(Attribute), pointer :: attr + class(*), pointer :: pTimeUnits + character(len=ESMF_MAXSTR) :: datetime_units + character(len=ESMF_MAXSTR) :: tunit + type(ESMF_time), allocatable :: esmf_time_1d(:) + real(kind=ESMF_KIND_R8), allocatable :: rtime_1d(:) + + var => this%metadata%get_variable('time',_RC) + attr => var%get_attribute('units') + ptimeUnits => attr%get_value() + select type(pTimeUnits) + type is (character(*)) + datetime_units = ptimeUnits + class default + _FAIL("Time unit must be character") + end select + allocate ( esmf_time_1d(1), rtime_1d(1) ) + esmf_time_1d(1)= current_time + call time_ESMF_to_real ( rtime_1d, esmf_time_1d, datetime_units, _RC ) + rtime = rtime_1d(1) + + _RETURN(_SUCCESS) + end procedure compute_time_for_current + + + +end submodule MaskSamplerGeosat_implement diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 index 9efd6ca1ac25..ab646a3ea0d3 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 @@ -24,6 +24,7 @@ module HistoryTrajectoryMod real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: times_R8(:) integer, allocatable :: obstype_id(:) + integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file type(ESMF_FieldBundle) :: bundle type(ESMF_FieldBundle) :: output_bundle @@ -56,6 +57,7 @@ module HistoryTrajectoryMod character(len=ESMF_MAXSTR) :: var_name_lat_full character(len=ESMF_MAXSTR) :: var_name_lon_full character(len=ESMF_MAXSTR) :: datetime_units + character(len=ESMF_MAXSTR) :: Location_index_name integer :: epoch ! unit: second integer(kind=ESMF_KIND_I8) :: epoch_index(2) real(kind=ESMF_KIND_R8), pointer:: obsTime(:) diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 index d266b34e1f93..165c40a42331 100644 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 @@ -300,12 +300,17 @@ if (this%time_info%integer_time) then v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) else - v = Variable(type=PFIO_REAL32,dimensions=this%index_name_x) + v = Variable(type=PFIO_REAL64,dimensions=this%index_name_x) end if call v%add_attribute('units', this%datetime_units) call v%add_attribute('long_name', 'dateTime') call this%obs(k)%metadata%add_variable(this%var_name_time,v) + v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'Location index in corresponding IODA file') + call this%obs(k)%metadata%add_variable(this%location_index_name,v) + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) call v%add_attribute('units','degrees_east') call v%add_attribute('long_name','longitude') @@ -494,12 +499,17 @@ real(kind=REAL64), allocatable :: lons_full(:), lats_full(:) real(kind=REAL64), allocatable :: times_R8_full(:) + real(kind=REAL64) :: t_shift integer, allocatable :: obstype_id_full(:) + integer, allocatable :: location_index_ioda_full(:) + integer, allocatable :: IA_full(:) real(ESMF_KIND_R8), pointer :: ptAT(:) type(ESMF_routehandle) :: RH type(ESMF_Time) :: timeset(2) type(ESMF_Time) :: current_time + type(ESMF_Time) :: time0 + type(ESMF_TimeInterval) :: dt type(ESMF_Grid) :: grid type(ESMF_VM) :: vm @@ -512,6 +522,7 @@ integer(kind=ESMF_KIND_I8) :: nstart, nend real(kind=ESMF_KIND_R8) :: jx0, jx1 integer :: nx, nx_sum + integer :: n0 integer :: arr(1) integer :: sec integer, allocatable :: ix(:) ! counter for each obs(k)%nobs_epoch @@ -547,7 +558,8 @@ this%var_name_lat = this%var_name_lat_full(i+1:) i=index(this%var_name_time_full, '/') this%var_name_time= this%var_name_time_full(i+1:) - + this%location_index_name = 'location_index_in_iodafile' + call lgr%debug('%a', 'grp_name,this%index_name_x,this%var_name_lon,this%var_name_lat,this%var_name_time') call lgr%debug('%a %a %a %a %a', & trim(grp_name),trim(this%index_name_x),trim(this%var_name_lon),& @@ -587,6 +599,8 @@ allocate(lons_full(len),lats_full(len),_STAT) allocate(times_R8_full(len),_STAT) allocate(obstype_id_full(len),_STAT) + allocate(location_index_ioda_full(len),_STAT) + allocate(IA_full(len),_STAT) call lgr%debug('%a %i12', 'nobs from input file:', len) len = 0 ii = 0 @@ -607,8 +621,12 @@ this%datetime_units = trim(timeunits_file) call lgr%debug('%a %a', 'datetime_units from 1st file:', trim(timeunits_file)) end if + call diff_two_timeunits (this%datetime_units, timeunits_file, t_shift, _RC) + times_R8_full(len+1:len+num_times) = times_R8_full(len+1:len+num_times) + t_shift obstype_id_full(len+1:len+num_times) = k - !!write(6,'(f12.2)') times_R8_full(::50) + do jj = 1, num_times + location_index_ioda_full(len+jj) = jj + end do len = len + num_times end if j=j+1 @@ -617,12 +635,14 @@ end if end if + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) if (nx_sum == 0) then allocate(this%lons(0),this%lats(0),_STAT) allocate(this%times_R8(0),_STAT) allocate(this%obstype_id(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) this%epoch_index(1:2) = 0 this%nobs_epoch = 0 this%nobs_epoch_sum = 0 @@ -636,8 +656,6 @@ this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) this%obsTime= -1.d0 - - call lgr%debug('%a %i5', 'nobservation points=', nx_sum) rc = 0 return end if @@ -646,6 +664,8 @@ if (mapl_am_I_root()) then + call sort_index (times_R8_full, IA_full, _RC) + call apply_order_index (location_index_ioda_full, IA_full, _RC) ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) call ESMF_ClockGet(this%clock,currTime=current_time,_RC) @@ -689,17 +709,22 @@ allocate(this%lons(0),this%lats(0),_STAT) allocate(this%times_R8(0),_STAT) allocate(this%obstype_id(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) this%epoch_index(1:2)=0 this%nobs_epoch = 0 nx=0 arr(1)=nx else + !! doulbe check ! (x1, x2] design in bisect - if (jt1==0) then - this%epoch_index(1)= 1 - else - this%epoch_index(1)= jt1 - endif + this%epoch_index(1)= jt1 + 1 + +!! ! (x1, x2] design in bisect +!! if (jt1==0) then +!! this%epoch_index(1)= 1 +!! else +!! this%epoch_index(1)= jt1 +!! endif _ASSERT(jt2<=len, 'bisect index for this%epoch_index(2) failed') if (jt2==0) then this%epoch_index(2)= 1 @@ -714,6 +739,7 @@ allocate(this%lons(nx),this%lats(nx),_STAT) allocate(this%times_R8(nx),_STAT) allocate(this%obstype_id(nx),_STAT) + allocate(this%location_index_ioda(nx),_STAT) j=this%epoch_index(1) do i=1, nx @@ -721,6 +747,7 @@ this%lats(i) = lats_full(j) this%times_R8(i) = times_R8_full(j) this%obstype_id(i) = obstype_id_full(j) + this%location_index_ioda(i) = location_index_ioda_full(j) j=j+1 enddo arr(1)=nx @@ -738,6 +765,7 @@ allocate (this%obs(k)%lons(nx2)) allocate (this%obs(k)%lats(nx2)) allocate (this%obs(k)%times_R8(nx2)) + allocate (this%obs(k)%location_index_ioda(nx2)) enddo allocate(ix(this%nobs_type)) @@ -749,13 +777,14 @@ this%obs(k)%lons(ix(k)) = lons_full(j) this%obs(k)%lats(ix(k)) = lats_full(j) this%obs(k)%times_R8(ix(k)) = times_R8_full(j) + this%obs(k)%location_index_ioda(ix(k)) = location_index_ioda_full(j) !if (mod(k,10**8)==1) then ! write(6,*) 'this%obs(k)%times_R8(ix(k))', this%obs(k)%times_R8(ix(k)) !endif j=j+1 enddo deallocate(ix) - deallocate(lons_full, lats_full, times_R8_full, obstype_id_full) + deallocate(lons_full, lats_full, times_R8_full, obstype_id_full, location_index_ioda_full) call lgr%debug('%a %i12 %i12 %i12', & 'epoch_index(1:2), nx', this%epoch_index(1), & @@ -769,6 +798,7 @@ allocate(this%lons(0),this%lats(0),_STAT) allocate(this%times_R8(0),_STAT) allocate(this%obstype_id(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) this%epoch_index(1:2)=0 this%nobs_epoch = 0 nx=0 @@ -778,8 +808,9 @@ call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) this%nobs_epoch_sum = nx_sum - if (mapl_am_I_root()) write(6,'(2x,a,2x,i15)') 'nobs in Epoch :', nx_sum + call lgr%debug('%a %i20', 'nobservation points=', nx_sum) + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) this%LS_rt = this%locstream_factory%create_locstream(_RC) call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) @@ -851,6 +882,8 @@ start=[is], count=[nx], _RC) call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & + start=[is], count=[nx], _RC) end if end if enddo @@ -1025,6 +1058,11 @@ _RETURN(ESMF_SUCCESS) endif + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + call ESMF_ClockGet(this%clock,currTime=current_time,_RC) call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) timeset(1) = current_time - dur @@ -1037,7 +1075,7 @@ ! ! __ I designed a method to return from regridding if no valid points exist - ! in reality for 29 jedi platforms and dt > 20 sec, we donot need this + ! in reality for 29 ioda platforms and dt > 20 sec, we donot need this ! !!arr(1)=1 !!if (.NOT. (is > 0 .AND. is <= ie )) arr(1)=0 @@ -1125,7 +1163,7 @@ call this%locstream_factory%destroy_locstream(this%LS_ds, _RC) call this%regridder%destroy(_RC) deallocate (this%lons, this%lats, & - this%times_R8, this%obstype_id) + this%times_R8, this%obstype_id, this%location_index_ioda) do k=1, this%nobs_type deallocate (this%obs(k)%metadata) @@ -1145,6 +1183,9 @@ if (allocated (this%obs(k)%times_R8)) then deallocate (this%obs(k)%times_R8) end if + if (allocated (this%obs(k)%location_index_ioda)) then + deallocate (this%obs(k)%location_index_ioda) + end if if (allocated(this%obs(k)%p2d)) then deallocate (this%obs(k)%p2d) endif @@ -1207,7 +1248,10 @@ !! !! I choose UB = N+1 not N, because my sub. bisect find n: Y(n)=2 .AND. ncount<=4).OR.(ncount==0) _ASSERT(con1, 'string sequence in Aeronet file not supported') if (ncount==0) then @@ -141,26 +141,31 @@ function new_StationSampler_readfile (filename,nskip_line, rc) result(sampler) read(unit, *) & sampler%station_id(i), & sampler%station_name(i), & - sampler%lats(i), & - sampler%lons(i) + sampler%lons(i), & + sampler%lats(i) elseif(seq=='AIFFF') then read(unit, *) & sampler%station_name(i), & sampler%station_id(i), & - sampler%lats(i), & - sampler%lons(i) + sampler%lons(i), & + sampler%lats(i) elseif(trim(seq)=='AFF' .OR. trim(seq)=='AFFF') then - read(unit, *) & + !!write(6,*) 'i=', i + line='' + read(unit, '(a100)') line + !!write(6,*) 'line=', trim(line) + call CSV_read_line_with_CH_I_R(line, & sampler%station_name(i), & - sampler%lats(i), & - sampler%lons(i) + sampler%lons(i), & + sampler%lats(i), _RC) sampler%station_id(i)=i elseif(trim(seq)=='AFFFA') then ! Ex: 'ZI000067991 -22.2170 30.0000 457.0 BEITBRIDGE 67991' read(unit, *) & sampler%station_name(i), & - sampler%lats(i), & - sampler%lons(i) + sampler%lons(i), & + sampler%lats(i) + sampler%station_id(i)=i backspace(unit) read(unit, '(a100)', IOSTAT=ios) line @@ -265,6 +270,9 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) v = Variable(type=pFIO_INT32, dimensions='station_index') call this%fmd%add_variable('station_id',v) + v = Variable(type=pFIO_STRING, dimensions='station_index') + call v%add_attribute('long_name','station name') + call this%fmd%add_variable('station_name',v) !__ 2. filemetadata: extract field from bundle, add_variable @@ -401,7 +409,7 @@ subroutine create_file_handle(this,filename,rc) character(len=*), intent(inout) :: filename ! for ouput nc integer, optional, intent(out) :: rc type(variable) :: v - integer :: status + integer :: status, j this%ofile = trim(filename) v = this%time_info%define_time_variable(_RC) @@ -416,6 +424,7 @@ subroutine create_file_handle(this,filename,rc) call this%formatter%put_var('longitude',this%lons,_RC) call this%formatter%put_var('latitude',this%lats,_RC) call this%formatter%put_var('station_id',this%station_id,_RC) + call this%formatter%put_var('station_name',this%station_name,_RC) _RETURN(_SUCCESS) end subroutine create_file_handle @@ -562,11 +571,13 @@ subroutine get_file_start_time(this,start_time,time_units,rc) end subroutine get_file_start_time ! TODO: delete and use system utilities when available - Subroutine count_substring (str, t, ncount) + Subroutine count_substring (str, t, ncount, rc) character (len=*), intent(in) :: str character (len=*), intent(in) :: t integer, intent(out) :: ncount + integer, optional, intent(out) :: rc integer :: i, k, lt + integer :: status ncount=0 k=1 lt = len(t) - 1 @@ -576,6 +587,45 @@ Subroutine count_substring (str, t, ncount) ncount = ncount + 1 k=k+i+lt end do + _RETURN(_SUCCESS) end subroutine count_substring + + subroutine CSV_read_line_with_CH_I_R(line, name, lon, lat, rc) + character (len=*), intent(in) :: line + character (len=*), intent(out) :: name + real(kind=REAL64), intent(out) :: lon, lat + integer, optional, intent(out) :: rc + integer :: n + integer :: i, j, k + integer :: status + + i=index(line, ',') + j=index(line(i+1:), ',') + _ASSERT (i>0, 'not CSV format') + _ASSERT (j>0, 'CSV format: find only 1 comma, should be > 1') + j=i+j + + read(line(1:i-1), '(a100)') name + k=index(line(i+1:j-1), '.') + if (k > 0) then + read(line(i+1:j-1), *) lon + else + read(line(i+1:j-1), *) i + lon = i + endif + + k=index(line(j+1:), '.') + if (k > 0) then + read(line(j+1:), *) lat + else + read(line(j+1:), *) i + lat = i + endif + + !!write(6,*) trim(name), lon, lat + _RETURN(_SUCCESS) + + end subroutine CSV_read_line_with_CH_I_R + end module StationSamplerMod From 3cfa1f7f52d37dc602722868d4d516a23826f189 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 13 Feb 2024 11:22:41 -0700 Subject: [PATCH 028/141] Fix the error in mask code: LocStreamFactory accept degree not radian, ESMF_grid farray is in radian --- .../MAPL_HistoryMaskGeosatMod_smod.F90 | 94 +++++-------------- 1 file changed, 24 insertions(+), 70 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 b/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 index d48b52f0c029..3013c4f313ef 100644 --- a/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 +++ b/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 @@ -120,8 +120,8 @@ end if end if - this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) - if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) +! this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) +! if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) this%ofile = '' this%obs_written = 0 @@ -181,8 +181,8 @@ integer :: ccount(2) integer :: tcount(2) integer(ESMF_KIND_I4), pointer :: farrayPtr(:,:) - real(ESMF_KIND_R8), pointer :: ptA(:) - real(ESMF_KIND_R8), pointer :: ptB(:) + real(ESMF_KIND_R8), pointer :: ptA(:) => NULL() + real(ESMF_KIND_R8), pointer :: ptB(:) => NULL() character(len=50) :: filename integer :: unit @@ -239,7 +239,7 @@ call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) call get_att_real_netcdf (fn, key_p, key_p_att, lambda0_deg, _RC) - lam_sat = lambda0_deg*MAPL_DEGREES_TO_RADIANS_R8 + lam_sat = lambda0_deg * MAPL_DEGREES_TO_RADIANS_R8 nx=0 do i=1, xdim_red @@ -261,8 +261,8 @@ call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) if (mask0 > 0) then nx=nx+1 - lons(nx) = lon0 - lats(nx) = lat0 + lons(nx) = lon0 * MAPL_RADIANS_TO_DEGREES + lats(nx) = lat0 * MAPL_RADIANS_TO_DEGREES end if end do end do @@ -316,29 +316,18 @@ call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) call ESMF_FieldDestroy(fieldA,nogarbage=.true.,_RC) call ESMF_FieldDestroy(fieldB,nogarbage=.true.,_RC) - call ESMF_VMBarrier (vm, _RC) - - !!- debug - !! write(6,'(2x,a,i5,100f10.1)') 'lons_ds pet=', mypet, lons_ds(::1000) - !! write(6,'(2x,a,i5,100f10.1)') 'lats_ds pet=', mypet, lats_ds(::2000) ! __ s3. find n.n. CS pts for LS_ds (halo) ! - obs_lons = lons_ds - obs_lats = lats_ds + obs_lons = lons_ds * MAPL_DEGREES_TO_RADIANS_R8 + obs_lats = lats_ds * MAPL_DEGREES_TO_RADIANS_R8 nx = size ( lons_ds ) allocate ( II(nx), JJ(nx) ) call MPI_Barrier(mpic, status) call MAPL_GetHorzIJIndex(nx,II,JJ,lonR8=obs_lons,latR8=obs_lats,grid=grid,_RC) call ESMF_VMBarrier (vm, _RC) - !! write(6,*) 'nx', nx - !! do i=1,nx,20 - !! write(6,'(2x,a,i5,i10,2f12.2,10i5)') 'pet,i,lon,lat,II,JJ=', mypet,i,& - !! obs_lons(i),obs_lats(i),II(i),JJ(i) - !! end do - ! ! __ halo for mask ! @@ -363,25 +352,10 @@ endif enddo -! debug -! write(6,'(2x,a,2x,i5)') 'pet=', mypet -! do j=tUB(2), tLB(2), -1 -! write(6, '(2x,100i5)') farrayPtr(tLB(1):tUB(1), j) -! end do - call ESMF_FieldHaloStore (fieldI4, routehandle=RH_halo, _RC) call ESMF_FieldHalo (fieldI4, routehandle=RH_halo, _RC) call ESMF_VMBarrier (vm, _RC) -! write(filename, '(i5)') mypet -! filename='t.'//trim(adjustl(filename)) -! open(newunit=unit, file=trim(filename), status='unknown', _IOSTAT) -! write(6,'(2x,a,2x,5i20)') 'pet,unit', mypet, unit -! write(unit,'(2x,a,2x,i5)') 'AF pet=', mypet -! do j=tUB(2), tLB(2), -1 -! write(unit, '(2x,100i5)') farrayPtr(tLB(1):tUB(1), j) -! end do - k=0 do i=eLB(1), eUB(1) do j=eLB(2), eUB(2) @@ -415,32 +389,11 @@ end do end do -! ! -! ! -- test and print mask locations -! ! -! write(unit,'(2x,a,2x,i5)') 'connect pet=', mypet -! do j=tUB(2), tLB(2), -1 -! write(unit, '(2x,100i5)') farrayPtr(tLB(1):tUB(1), j) -! end do -! write(unit,'(2x,a,2x,i5)') 'mask pet=', mypet -! do j=eUB(2), eLB(2), -1 -! write(unit, '(2x,100i5)') mask(eLB(1):eUB(1), j) -! end do -! -! write(6,'(2x,a,2x,7i10)') 'this%npt_mask, this%npt_mask_tot', this%npt_mask, this%npt_mask_tot -! write(6,'(2x,a,2x,7i10)') 'this%index_mask(1,1:N)', this%index_mask(1,::5) -! write(6,'(2x,a,2x,7i10)') 'this%index_mask(2,1:N)', this%index_mask(2,::5) -! -! close(unit) -! - - ! FINISH: I have what I need - ! Fixed: npt_mask + index_mask - ! I have index on each PET, - ! The rest is station sampler, except - ! regridding is replaced by - ! - selecting masked data on PET - ! - mpi_gatherV + + ! ---- + ! regridding is replaced by + ! - selecting masked data on PET + ! - mpi_gatherV ! @@ -458,12 +411,7 @@ lons(i) = lons_ptr (ix, jx) lats(i) = lats_ptr (ix, jx) end do - - !if (mapl_am_i_root()) then - ! write(6,'(2x,10f8.1)') lons(::5) - ! write(6,'(2x,10f8.1)') lats(::5) - ! print*, 'end lons/lats' - !end if + call ESMF_VMBarrier (vm, _RC) iroot=0 if (mapl_am_i_root()) then @@ -730,6 +678,8 @@ module procedure create_file_handle type(variable) :: v integer :: status, j + real(kind=REAL64), allocatable :: x(:) + integer :: nx this%ofile = trim(filename) v = this%time_info%define_time_variable(_RC) @@ -743,8 +693,12 @@ call this%formatter%create(trim(filename),_RC) call this%formatter%write(this%metadata,_RC) - call this%formatter%put_var('longitude',this%lons,_RC) - call this%formatter%put_var('latitude',this%lats,_RC) + nx = size (this%lons) + allocate ( x(nx) ) + x(:) = this%lons(:) * MAPL_RADIANS_TO_DEGREES + call this%formatter%put_var('longitude',x,_RC) + x(:) = this%lats(:) * MAPL_RADIANS_TO_DEGREES + call this%formatter%put_var('latitude',x,_RC) ! call this%formatter%put_var('mask_id',this%mask_id,_RC) ! call this%formatter%put_var('mask_name',this%mask_name,_RC) @@ -774,7 +728,7 @@ character(len=ESMF_MAXSTR) :: tunit type(ESMF_time), allocatable :: esmf_time_1d(:) real(kind=ESMF_KIND_R8), allocatable :: rtime_1d(:) - + var => this%metadata%get_variable('time',_RC) attr => var%get_attribute('units') ptimeUnits => attr%get_value() From 74f27ad897f74c0985e4bc6855f7cd883cdb5a18 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 13 Feb 2024 12:16:26 -0700 Subject: [PATCH 029/141] add Sampler directory under History --- gridcomps/History/CMakeLists.txt | 12 +- .../History/Sampler/MAPL_EpochSwathMod.F90 | 1258 ++++++++++++++++ .../History/Sampler/MAPL_GeosatMaskMod.F90 | 179 +++ .../Sampler/MAPL_GeosatMaskMod_smod.F90 | 751 ++++++++++ .../Sampler/MAPL_StationSamplerMod.F90 | 631 ++++++++ .../History/Sampler/MAPL_TrajectoryMod.F90 | 162 +++ .../Sampler/MAPL_TrajectoryMod_smod.F90 | 1275 +++++++++++++++++ 7 files changed, 4262 insertions(+), 6 deletions(-) create mode 100644 gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 create mode 100644 gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 create mode 100644 gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 create mode 100644 gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 create mode 100644 gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 create mode 100644 gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 diff --git a/gridcomps/History/CMakeLists.txt b/gridcomps/History/CMakeLists.txt index 556360cdd180..58af30a30b27 100644 --- a/gridcomps/History/CMakeLists.txt +++ b/gridcomps/History/CMakeLists.txt @@ -1,14 +1,14 @@ esma_set_this (OVERRIDE MAPL.history) set (srcs - MAPL_HistoryTrajectoryMod.F90 - MAPL_HistoryTrajectoryMod_smod.F90 MAPL_HistoryCollection.F90 MAPL_HistoryGridComp.F90 - MAPL_EpochSwathMod.F90 - MAPL_StationSamplerMod.F90 - MAPL_HistoryMaskGeosatMod.F90 - MAPL_HistoryMaskGeosatMod_smod.F90 + Sampler/MAPL_EpochSwathMod.F90 + Sampler/MAPL_GeosatMaskMod.F90 + Sampler/MAPL_GeosatMaskMod_smod.F90 + Sampler/MAPL_StationSamplerMod.F90 + Sampler/MAPL_TrajectoryMod.F90 + Sampler/MAPL_TrajectoryMod_smod.F90 ) esma_add_library (${this} SRCS ${srcs} DEPENDENCIES MAPL.shared MAPL.constants MAPL.base MAPL.generic MAPL.profiler MAPL.griddedio diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 new file mode 100644 index 000000000000..ae42ac808963 --- /dev/null +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -0,0 +1,1258 @@ +! +! __ Analogy to GriddedIO.F90 with a twist for Epoch Swath grid +! +#include "MAPL_Generic.h" + +module MAPL_EpochSwathMod + use ESMF + use ESMFL_Mod + use MAPL_AbstractGridFactoryMod + use MAPL_AbstractRegridderMod + use MAPL_GridManagerMod + use MAPL_BaseMod + use MAPL_NewRegridderManager + use MAPL_RegridMethods + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_Constants + use pFIO + use MAPL_GriddedIOItemVectorMod + use MAPL_GriddedIOItemMod + use MAPL_ExceptionHandling + use pFIO_ClientManagerMod + use MAPL_DataCollectionMod + use MAPL_DataCollectionManagerMod + use gFTL_StringVector + use gFTL_StringStringMap + use MAPL_StringGridMapMod + use MAPL_FileMetadataUtilsMod + use MAPL_DownbitMod + use Plain_netCDF_Time + use, intrinsic :: ISO_C_BINDING + use MAPL_CommsMod, only : MAPL_Am_I_Root + implicit none + private + + integer, parameter :: ngrid_max = 10 + + type, private :: K_V_CF + character(len=ESMF_MAXSTR) :: key + type(ESMF_config) :: cf + end type K_V_CF + + type, public :: samplerHQ + type(ESMF_Clock) :: clock + type(ESMF_Alarm) :: alarm + type(ESMF_Time) :: RingTime + type(ESMF_TimeInterval) :: Frequency_epoch + integer :: ngrid = 0 + character(len=ESMF_MAXSTR) :: grid_type + character(len=ESMF_MAXSTR) :: tunit + type (K_V_CF) :: CF_loc(ngrid_max) + real*8 :: arr(2) + + contains + procedure :: create_grid + procedure :: regrid_accumulate => regrid_accumulate_on_xysubset + procedure :: destroy_rh_regen_ogrid + procedure :: fill_time_in_bundle + procedure :: find_config + procedure :: config_accumulate + end type samplerHQ + + interface samplerHQ + module procedure new_samplerHQ + end interface samplerHQ + + type, public :: sampler + type(FileMetaData), allocatable :: metadata + type(fileMetadataUtils), pointer :: current_file_metadata + integer :: write_collection_id + integer :: read_collection_id + integer :: metadata_collection_id + class (AbstractRegridder), pointer :: regrid_handle => null() + type(ESMF_Grid) :: output_grid + logical :: doVertRegrid = .false. + type(ESMF_FieldBundle) :: output_bundle + type(ESMF_FieldBundle) :: input_bundle + type(ESMF_FieldBundle) :: acc_bundle + type(ESMF_Time) :: startTime + integer :: regrid_method = REGRID_METHOD_BILINEAR + integer :: nbits_to_keep = MAPL_NBITS_NOT_SET + real, allocatable :: lons(:,:),lats(:,:) + real, allocatable :: corner_lons(:,:),corner_lats(:,:) + real, allocatable :: times(:) + type(TimeData) :: timeInfo + type(VerticalData) :: vdata + type(GriddedIOitemVector) :: items + integer :: deflateLevel = 0 + integer :: quantizeAlgorithm = 1 + integer :: quantizeLevel = 0 + integer, allocatable :: chunking(:) + logical :: itemOrderAlphabetical = .true. + integer :: fraction + logical :: have_initalized + contains +!! procedure :: CreateFileMetaData + procedure :: Create_bundle_RH + procedure :: CreateVariable + procedure :: regridScalar + procedure :: regridVector + procedure :: set_param + procedure :: set_default_chunking + procedure :: check_chunking + procedure :: alphabatize_variables + procedure :: addVariable_to_acc_bundle + procedure :: addVariable_to_output_bundle + procedure :: interp_accumulate_fields + end type sampler + + interface sampler + module procedure new_sampler + end interface sampler + +contains + + ! + ! in MAPL_HistoryGridComp.F90, Hsampler get its config and key + ! from the first SwathGrid entry in HISTORY.rc + ! thus + ! there is only one frequency_epoch for all the SwathGrid usage + ! + function new_samplerHQ(clock, key, config, rc) result(hq) + implicit none + type(samplerHQ) :: hq + type(ESMF_Clock), intent(in) :: clock + character(len=*), intent(in) :: key + type(ESMF_Config), intent(inout) :: config + integer, optional, intent(out) :: rc + + integer :: status + integer :: second + integer :: time_integer + type(ESMF_Time) :: startTime + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: timeStep + type(ESMF_TimeInterval) :: Frequency_epoch + + + hq%clock= clock + hq%arr(1:2) = -2.d0 + call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) + call ESMF_ClockGet ( clock, timestep=timestep, _RC ) + call ESMF_ClockGet ( clock, startTime=startTime, _RC ) + call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(key)//'.Epoch:', default=0, _RC) + call ESMF_ConfigGetAttribute(config, value=hq%tunit, label=trim(key)//'.tunit:', default="", _RC) + _ASSERT(time_integer /= 0, 'Epoch value in config wrong') + second = hms_2_s (time_integer) + call ESMF_TimeIntervalSet(frequency_epoch, s=second, _RC) + hq%frequency_epoch = frequency_epoch + hq%RingTime = currTime + hq%alarm = ESMF_AlarmCreate( clock=clock, RingInterval=Frequency_epoch, & + RingTime=hq%RingTime, sticky=.false., _RC ) + + _RETURN(_SUCCESS) + + end function new_samplerHQ + + + function find_config (this, key, rc) result(cf) + class(samplerHQ) :: this + character(len=*) , intent(in) :: key + type(ESMF_Config) :: cf + integer, intent(out), optional :: rc + integer :: status + integer :: i, j + + j=0 + do i=1, this%ngrid + if ( trim(key) == trim(this%CF_loc(i)%key) ) then + cf = this%CF_loc(i)%cf + j=j+1 + exit + end if + end do + + _ASSERT( j>0 , trim(key)//' is not found in Hsampler CF_loc(:)') + + _RETURN(_SUCCESS) + end function find_config + + + subroutine config_accumulate (this, key, cf, rc) + class(samplerHQ) :: this + type(ESMF_Config), intent(in) :: cf + character(len=*) , intent(in) :: key + integer, intent(out), optional :: rc + integer :: status + + this%ngrid = this%ngrid + 1 + this%CF_loc(this%ngrid)%key = trim(key) + this%CF_loc(this%ngrid)%cf = cf + _RETURN(_SUCCESS) + end subroutine config_accumulate + + + !--------------------------------------------------! + ! __ set + ! - ogrid via grid_manager%make_grid + ! using currTime and HQ%config_grid_save + !--------------------------------------------------! + function create_grid(this, key, currTime, grid_type, rc) result(ogrid) + type (ESMF_Grid) :: ogrid + class(samplerHQ) :: this + character(len=*), intent(in) :: key + type(ESMF_Time), intent(inout) :: currTime + character(len=*), optional, intent(in) :: grid_type + integer, intent(out), optional :: rc + integer :: status + + type(ESMF_Config) :: config_grid + character(len=ESMF_MAXSTR) :: time_string + + + if (present(grid_type)) this%grid_type = trim(grid_type) + config_grid = this%find_config(key) + call ESMF_TimeGet(currTime, timeString=time_string, _RC) + + ! + ! -- the `ESMF_ConfigSetAttribute` shows a risk + ! to overwrite the nextline in config + ! + call ESMF_ConfigSetAttribute( config_grid, trim(time_string), label=trim(key)//'.Epoch_init:', _RC) + + ogrid = grid_manager%make_grid(config_grid, prefix=trim(key)//'.', _RC ) + !! call grid_validate (ogrid,) + + _RETURN(_SUCCESS) + + end function create_grid + + + subroutine regrid_accumulate_on_xysubset (this, sp, rc) + class(samplerHQ) :: this + class(sampler), intent(inout) :: sp + integer, intent(out), optional :: rc + integer :: status + + class(AbstractGridFactory), pointer :: factory + type(ESMF_Time) :: timeset(2) + type(ESMF_Time) :: current_time + type(ESMF_TimeInterval) :: dur + integer :: xy_subset(2,2) + + ! __ s1. get xy_subset + + call ESMF_ClockGet(this%clock,currTime=current_time,_RC) + call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) + timeset(1) = current_time - dur + timeset(2) = current_time + + factory => grid_manager%get_factory(sp%output_grid,_RC) + call factory%get_xy_subset( timeset, xy_subset, _RC) + + ! __ s2. interpolate then save data using xy_mask + + call sp%interp_accumulate_fields (xy_subset, _RC) + + _RETURN(ESMF_SUCCESS) + + end subroutine regrid_accumulate_on_xysubset + + + subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) + implicit none + class(samplerHQ) :: this + class(sampler) :: sp + type (StringGridMap), target, intent(inout) :: output_grids + character(len=*), intent(in) :: key_grid_label + integer, intent(out), optional :: rc + integer :: status + + type(ESMF_Time) :: currTime + type(ESMF_Grid), pointer :: pgrid + type(ESMF_Grid) :: ogrid + character(len=ESMF_MAXSTR) :: key_str + type (StringGridMapIterator) :: iter + character(len=:), pointer :: key + + integer :: i, numVars + character(len=ESMF_MAXSTR), allocatable :: names(:) + type(ESMF_Field) :: field + + if ( .NOT. ESMF_AlarmIsRinging(this%alarm) ) then + _RETURN(ESMF_SUCCESS) + endif + + + !__ s1. destroy ogrid + RH, regen ogrid + + key_str = trim(key_grid_label) + pgrid => output_grids%at(key_str) + + call grid_manager%destroy(pgrid,_RC) + + call ESMF_ClockGet (this%clock, CurrTime=currTime, _RC ) + iter = output_grids%begin() + do while (iter /= output_grids%end()) + key => iter%key() + if (trim(key)==trim(key_str)) then + ogrid = this%create_grid (key_str, currTime, _RC) + call output_grids%set(key, ogrid) + endif + call iter%next() + enddo + + + !__ s2. destroy RH + call sp%regrid_handle%destroy(_RC) + + + + !__ s3. destroy acc_bundle / output_bundle + + call ESMF_FieldBundleGet(sp%acc_bundle,fieldCount=numVars,_RC) + allocate(names(numVars),stat=status) + call ESMF_FieldBundleGet(sp%acc_bundle,fieldNameList=names,_RC) + do i=1,numVars + call ESMF_FieldBundleGet(sp%acc_bundle,trim(names(i)),field=field,_RC) + call ESMF_FieldDestroy(field,noGarbage=.true., _RC) + enddo + call ESMF_FieldBundleDestroy(sp%acc_bundle,noGarbage=.true.,_RC) + + call ESMF_FieldBundleGet(sp%output_bundle,fieldCount=numVars,_RC) + allocate(names(numVars),stat=status) + call ESMF_FieldBundleGet(sp%output_bundle,fieldNameList=names,_RC) + do i=1,numVars + call ESMF_FieldBundleGet(sp%output_bundle,trim(names(i)),field=field,_RC) + call ESMF_FieldDestroy(field,noGarbage=.true., _RC) + enddo + call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) + + _RETURN(ESMF_SUCCESS) + + end subroutine destroy_rh_regen_ogrid + + + subroutine fill_time_in_bundle (this, xname, bundle, ogrid, rc) + implicit none + class(samplerHQ) :: this + character(len=*), intent(in) :: xname + type(ESMF_FieldBundle), intent(inout) :: bundle + integer, optional, intent(out) :: rc + integer :: status + + type(ESMF_Grid), intent(in) :: ogrid + class(AbstractGridFactory), pointer :: factory + type(ESMF_Field) :: field + real(kind=ESMF_KIND_R4), pointer :: ptr2d(:,:) + + ! __ get field xname='time' + call ESMF_FieldBundleGet (bundle, xname, field=field, _RC) + call ESMF_FieldGet (field, farrayptr=ptr2d, _RC) + + ! __ obs_time from swath factory + factory => grid_manager%get_factory(ogrid,_RC) + call factory%get_obs_time (ogrid, ptr2d, _RC) + + _RETURN(ESMF_SUCCESS) + + end subroutine fill_time_in_bundle + + + function new_sampler(metadata,input_bundle,output_bundle,write_collection_id,read_collection_id, & + metadata_collection_id,regrid_method,fraction,items,rc) result(GriddedIO) + type(sampler) :: GriddedIO + type(Filemetadata), intent(in), optional :: metadata + type(ESMF_FieldBundle), intent(in), optional :: input_bundle + type(ESMF_FieldBundle), intent(in), optional :: output_bundle + integer, intent(in), optional :: write_collection_id + integer, intent(in), optional :: read_collection_id + integer, intent(in), optional :: metadata_collection_id + integer, intent(in), optional :: regrid_method + integer, intent(in), optional :: fraction + type(GriddedIOitemVector), intent(in), optional :: items + integer, intent(out), optional :: rc + + if (present(metadata)) GriddedIO%metadata=metadata + if (present(input_bundle)) GriddedIO%input_bundle=input_bundle + if (present(output_bundle)) GriddedIO%output_bundle=output_bundle + if (present(regrid_method)) GriddedIO%regrid_method=regrid_method + if (present(write_collection_id)) GriddedIO%write_collection_id=write_collection_id + if (present(read_collection_id)) GriddedIO%read_collection_id=read_collection_id + if (present(metadata_collection_id)) GriddedIO%metadata_collection_id=metadata_collection_id + if (present(items)) GriddedIO%items=items + if (present(fraction)) GriddedIO%fraction=fraction + _RETURN(ESMF_SUCCESS) + end function new_sampler + + + subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) + class (sampler), intent(inout) :: this + type(GriddedIOitemVector), target, intent(inout) :: items + type(ESMF_FieldBundle), intent(inout) :: bundle + character(len=*), intent(in) :: tunit + type(TimeData), optional, intent(inout) :: timeInfo + type(VerticalData), intent(inout), optional :: vdata + type (ESMF_Grid), intent(inout), pointer, optional :: ogrid + integer, intent(out), optional :: rc + + type(ESMF_Grid) :: input_grid + class (AbstractGridFactory), pointer :: factory + + type(ESMF_Field) :: new_field + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + integer :: status + + this%items = items + this%input_bundle = bundle + this%output_bundle = ESMF_FieldBundleCreate(rc=status) + _VERIFY(status) + if(present(timeInfo)) this%timeInfo = timeInfo + call ESMF_FieldBundleGet(this%input_bundle,grid=input_grid,rc=status) + _VERIFY(status) + if (present(ogrid)) then + this%output_grid=ogrid + else + call ESMF_FieldBundleGet(this%input_bundle,grid=this%output_grid,rc=status) + _VERIFY(status) + end if + this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) + _VERIFY(status) + + ! We get the regrid_method here because in the case of Identity, we set it to + ! REGRID_METHOD_IDENTITY in the regridder constructor if identity. Now we need + ! to change the regrid_method in the GriddedIO object to be the same as the + ! the regridder object. + this%regrid_method = this%regrid_handle%get_regrid_method() + + call ESMF_FieldBundleSet(this%output_bundle,grid=this%output_grid,rc=status) + _VERIFY(status) + factory => get_factory(this%output_grid,rc=status) + _VERIFY(status) + + ! __ please note, metadata in this section is not used in put_var to netCDF + ! the design used mGriddedIO%metadata in MAPL_HistoryGridComp.F90 + ! In other words, factory%append_metadata appeared here and in GriddedIO.F90 + ! + if (allocated(this%metadata)) then + deallocate (this%metadata) + end if + allocate(this%metadata) + call factory%append_metadata(this%metadata) + if (present(vdata)) then + this%vdata=vdata + else + this%vdata=VerticalData(rc=status) + _VERIFY(status) + end if + + call this%vdata%append_vertical_metadata(this%metadata,this%input_bundle,rc=status) + _VERIFY(status) + this%doVertRegrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%input_bundle,rc=status) + _VERIFY(status) + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call this%CreateVariable(item%xname,rc=status) + _VERIFY(status) + else if (item%itemType == ItemTypeVector) then + call this%CreateVariable(item%xname,rc=status) + _VERIFY(status) + call this%CreateVariable(item%yname,rc=status) + _VERIFY(status) + end if + call iter%next() + enddo + + + ! __ add acc_bundle and output_bundle + ! + this%acc_bundle = ESMF_FieldBundleCreate(_RC) + call ESMF_FieldBundleSet(this%acc_bundle,grid=this%output_grid,_RC) + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + call this%addVariable_to_acc_bundle(item%xname,_RC) + if (item%itemType == ItemTypeVector) then + call this%addVariable_to_acc_bundle(item%yname,_RC) + end if + call iter%next() + enddo + + + ! __ add time to acc_bundle + ! + new_field = ESMF_FieldCreate(this%output_grid ,name='time', & + typekind=ESMF_TYPEKIND_R4,_RC) + ! + ! add attribute + ! + call ESMF_AttributeSet(new_field,'UNITS',trim(tunit),_RC) + call MAPL_FieldBundleAdd( this%acc_bundle, new_field, _RC ) + + _RETURN(_SUCCESS) + end subroutine Create_Bundle_RH + + + subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,nbits_to_keep,regrid_method,itemOrder,write_collection_id,rc) + class (sampler), intent(inout) :: this + integer, optional, intent(in) :: deflation + integer, optional, intent(in) :: quantize_algorithm + integer, optional, intent(in) :: quantize_level + integer, optional, intent(in) :: chunking(:) + integer, optional, intent(in) :: nbits_to_keep + integer, optional, intent(in) :: regrid_method + logical, optional, intent(in) :: itemOrder + integer, optional, intent(in) :: write_collection_id + integer, optional, intent(out) :: rc + + integer :: status + + if (present(regrid_method)) this%regrid_method=regrid_method + if (present(nbits_to_keep)) this%nbits_to_keep=nbits_to_keep + if (present(deflation)) this%deflateLevel = deflation + if (present(quantize_algorithm)) this%quantizeAlgorithm = quantize_algorithm + if (present(quantize_level)) this%quantizeLevel = quantize_level + if (present(chunking)) then + allocate(this%chunking,source=chunking,stat=status) + _VERIFY(status) + end if + if (present(itemOrder)) this%itemOrderAlphabetical = itemOrder + if (present(write_collection_id)) this%write_collection_id=write_collection_id + _RETURN(ESMF_SUCCESS) + + end subroutine set_param + + subroutine set_default_chunking(this,rc) + class (sampler), intent(inout) :: this + integer, optional, intent(out) :: rc + + integer :: global_dim(3) + integer :: status + + call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + if (global_dim(1)*6 == global_dim(2)) then + allocate(this%chunking(5)) + this%chunking(1) = global_dim(1) + this%chunking(2) = global_dim(1) + this%chunking(3) = 1 + this%chunking(4) = 1 + this%chunking(5) = 1 + else + allocate(this%chunking(4)) + this%chunking(1) = global_dim(1) + this%chunking(2) = global_dim(2) + this%chunking(3) = 1 + this%chunking(4) = 1 + endif + _RETURN(ESMF_SUCCESS) + + end subroutine set_default_chunking + + subroutine check_chunking(this,lev_size,rc) + class (sampler), intent(inout) :: this + integer, intent(in) :: lev_size + integer, optional, intent(out) :: rc + + integer :: global_dim(3) + integer :: status + character(len=5) :: c1,c2 + + call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) + _VERIFY(status) + if (global_dim(1)*6 == global_dim(2)) then + write(c2,'(I5)')global_dim(1) + write(c1,'(I5)')this%chunking(1) + _ASSERT(this%chunking(1) <= global_dim(1), "Chunk for Xdim "//c1//" must be less than or equal to "//c2) + write(c1,'(I5)')this%chunking(2) + _ASSERT(this%chunking(2) <= global_dim(1), "Chunk for Ydim "//c1//" must be less than or equal to "//c2) + _ASSERT(this%chunking(3) <= 6, "Chunksize for face dimension must be 6 or less") + if (lev_size > 0) then + write(c2,'(I5)')lev_size + write(c1,'(I5)')this%chunking(4) + _ASSERT(this%chunking(4) <= lev_size, "Chunk for level size "//c1//" must be less than or equal to "//c2) + end if + _ASSERT(this%chunking(5) == 1, "Time must have chunk size of 1") + else + write(c2,'(I5)')global_dim(1) + write(c1,'(I5)')this%chunking(1) + _ASSERT(this%chunking(1) <= global_dim(1), "Chunk for lon "//c1//" must be less than or equal to "//c2) + write(c2,'(I5)')global_dim(2) + write(c1,'(I5)')this%chunking(2) + _ASSERT(this%chunking(2) <= global_dim(2), "Chunk for lat "//c1//" must be less than or equal to "//c2) + if (lev_size > 0) then + write(c2,'(I5)')lev_size + write(c1,'(I5)')this%chunking(3) + _ASSERT(this%chunking(3) <= lev_size, "Chunk for level size "//c1//" must be less than or equal to "//c2) + end if + _ASSERT(this%chunking(4) == 1, "Time must have chunk size of 1") + endif + _RETURN(ESMF_SUCCESS) + + end subroutine check_chunking + + subroutine CreateVariable(this,itemName,rc) + class (sampler), intent(inout) :: this + character(len=*), intent(in) :: itemName + integer, optional, intent(out) :: rc + + integer :: status + + type(ESMF_Field) :: field,newField + class (AbstractGridFactory), pointer :: factory + integer :: fieldRank + logical :: isPresent + character(len=ESMF_MAXSTR) :: varName,longName,units + + + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) + _VERIFY(status) + factory => get_factory(this%output_grid,rc=status) + _VERIFY(status) + + + call ESMF_FieldGet(field,rank=fieldRank,rc=status) + _VERIFY(status) + call ESMF_FieldGet(field,name=varName,rc=status) + _VERIFY(status) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=isPresent,rc=status) + _VERIFY(status) + if ( isPresent ) then + call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=LongName, RC=STATUS) + _VERIFY(STATUS) + else + LongName = varName + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=isPresent,rc=status) + _VERIFY(status) + if ( isPresent ) then + call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, RC=STATUS) + _VERIFY(STATUS) + else + units = 'unknown' + endif + + + ! finally make a new field if neccessary + if (this%doVertRegrid .and. (fieldRank ==3) ) then + newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,rc=status) + _VERIFY(status) + call MAPL_FieldBundleAdd(this%output_bundle,newField,rc=status) + _VERIFY(status) + else + newField = MAPL_FieldCreate(field,this%output_grid,rc=status) + _VERIFY(status) + call MAPL_FieldBundleAdd(this%output_bundle,newField,rc=status) + _VERIFY(status) + end if + _RETURN(_SUCCESS) + + end subroutine CreateVariable + + + subroutine RegridScalar(this,itemName,rc) + class (sampler), intent(inout) :: this + character(len=*), intent(in) :: itemName + integer, optional, intent(out) :: rc + + integer :: status + + type(ESMF_Field) :: field,outField + integer :: fieldRank + real, pointer :: ptr3d(:,:,:),outptr3d(:,:,:) + real, pointer :: ptr2d(:,:), outptr2d(:,:) + real, allocatable, target :: ptr3d_inter(:,:,:) + type(ESMF_Grid) :: gridIn,gridOut + logical :: hasDE_in, hasDE_out + logical :: first_entry + + call ESMF_FieldBundleGet(this%output_bundle,itemName,field=outField,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%output_bundle,grid=gridOut,rc=status) + _VERIFY(status) + hasDE_in = MAPL_GridHasDE(gridIn,rc=status) + _VERIFY(status) + hasDE_out = MAPL_GridHasDE(gridOut,rc=status) + _VERIFY(status) + first_entry = .true. + if (this%doVertRegrid) then + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) + _VERIFY(status) + call ESMF_FieldGet(Field,rank=fieldRank,rc=status) + _VERIFY(status) + if (fieldRank==3) then + if (hasDE_in) then + call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) + _VERIFY(status) + else + allocate(ptr3d(0,0,0)) + end if + allocate(ptr3d_inter(size(ptr3d,1),size(ptr3d,2),this%vdata%lm),stat=status) + _VERIFY(status) + if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then + call this%vdata%regrid_select_level(ptr3d,ptr3d_inter,rc=status) + _VERIFY(status) + else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%regrid_eta_to_pressure(ptr3d,ptr3d_inter,rc=status) + _VERIFY(status) + else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then + call this%vdata%flip_levels(ptr3d,ptr3d_inter,rc=status) + _VERIFY(status) + end if + ptr3d => ptr3d_inter + end if + else + if (first_entry) then + nullify(ptr3d) + first_entry = .false. + end if + end if + + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) + _VERIFY(status) + call ESMF_FieldGet(field,rank=fieldRank,rc=status) + _VERIFY(status) + if (fieldRank==2) then + if (hasDE_in) then + call MAPL_FieldGetPointer(field,ptr2d,rc=status) + _VERIFY(status) + else + allocate(ptr2d(0,0)) + end if + if (hasDE_out) then + call MAPL_FieldGetPointer(OutField,outptr2d,rc=status) + _VERIFY(status) + else + allocate(outptr2d(0,0)) + end if + if (gridIn==gridOut) then + outPtr2d=ptr2d + else + if (this%regrid_method==REGRID_METHOD_FRACTION) ptr2d=ptr2d-this%fraction + call this%regrid_handle%regrid(ptr2d,outPtr2d,rc=status) + _VERIFY(status) + end if + +!! print *, maxval(ptr2d) +!! print *, minval(ptr2d) +!! print *, maxval(outptr2d) +!! print *, minval(outptr2d) + + else if (fieldRank==3) then + if (.not.associated(ptr3d)) then + if (hasDE_in) then + call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) + _VERIFY(status) + else + allocate(ptr3d(0,0,0)) + end if + end if + if (hasDE_out) then + call MAPL_FieldGetPointer(OutField,outptr3d,rc=status) + _VERIFY(status) + else + allocate(outptr3d(0,0,0)) + end if + if (gridIn==gridOut) then + outPtr3d=Ptr3d + else + if (this%regrid_method==REGRID_METHOD_FRACTION) ptr3d=ptr3d-this%fraction + call this%regrid_handle%regrid(ptr3d,outPtr3d,rc=status) + _VERIFY(status) + end if + else + _FAIL('rank not supported') + end if + + if (allocated(ptr3d_inter)) deallocate(ptr3d_inter) + _RETURN(_SUCCESS) + + end subroutine RegridScalar + + subroutine RegridVector(this,xName,yName,rc) + class (sampler), intent(inout) :: this + character(len=*), intent(in) :: xName + character(len=*), intent(in) :: yName + integer, optional, intent(out) :: rc + + integer :: status + + type(ESMF_Field) :: xfield,xoutField + type(ESMF_Field) :: yfield,youtField + integer :: fieldRank + real, pointer :: xptr3d(:,:,:),xoutptr3d(:,:,:) + real, pointer :: xptr2d(:,:), xoutptr2d(:,:) + real, allocatable, target :: xptr3d_inter(:,:,:) + real, pointer :: yptr3d(:,:,:),youtptr3d(:,:,:) + real, pointer :: yptr2d(:,:), youtptr2d(:,:) + real, allocatable, target :: yptr3d_inter(:,:,:) + type(ESMF_Grid) :: gridIn, gridOut + logical :: hasDE_in, hasDE_out + + call ESMF_FieldBundleGet(this%output_bundle,xName,field=xoutField,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%output_bundle,yName,field=youtField,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%output_bundle,grid=gridOut,rc=status) + _VERIFY(status) + hasDE_in = MAPL_GridHasDE(gridIn,rc=status) + _VERIFY(status) + hasDE_out = MAPL_GridHasDE(gridOut,rc=status) + _VERIFY(status) + + if (this%doVertRegrid) then + call ESMF_FieldBundleGet(this%input_bundle,xName,field=xfield,rc=status) + _VERIFY(status) + call ESMF_FieldGet(xField,rank=fieldRank,rc=status) + _VERIFY(status) + if (fieldRank==3) then + if (hasDE_in) then + call ESMF_FieldGet(xfield,farrayPtr=xptr3d,rc=status) + _VERIFY(status) + else + allocate(xptr3d(0,0,0)) + end if + allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),stat=status) + _VERIFY(status) + if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then + call this%vdata%regrid_select_level(xptr3d,xptr3d_inter,rc=status) + _VERIFY(status) + else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%regrid_eta_to_pressure(xptr3d,xptr3d_inter,rc=status) + _VERIFY(status) + else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then + call this%vdata%flip_levels(xptr3d,xptr3d_inter,rc=status) + _VERIFY(status) + end if + xptr3d => xptr3d_inter + end if + call ESMF_FieldBundleGet(this%input_bundle,yName,field=yfield,rc=status) + _VERIFY(status) + call ESMF_FieldGet(yField,rank=fieldRank,rc=status) + _VERIFY(status) + if (fieldRank==3) then + if (hasDE_in) then + call ESMF_FieldGet(yfield,farrayPtr=yptr3d,rc=status) + _VERIFY(status) + else + allocate(yptr3d(0,0,0)) + end if + allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),stat=status) + _VERIFY(status) + if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then + call this%vdata%regrid_select_level(yptr3d,yptr3d_inter,rc=status) + _VERIFY(status) + else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%regrid_eta_to_pressure(yptr3d,yptr3d_inter,rc=status) + _VERIFY(status) + else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then + call this%vdata%flip_levels(yptr3d,yptr3d_inter,rc=status) + _VERIFY(status) + end if + yptr3d => yptr3d_inter + end if + else + if (associated(xptr3d)) nullify(xptr3d) + if (associated(yptr3d)) nullify(yptr3d) + end if + + call ESMF_FieldBundleGet(this%input_bundle,xname,field=xfield,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%input_bundle,yname,field=yfield,rc=status) + _VERIFY(status) + call ESMF_FieldGet(xfield,rank=fieldRank,rc=status) + _VERIFY(status) + if (fieldRank==2) then + if (hasDE_in) then + call MAPL_FieldGetPointer(xfield,xptr2d,rc=status) + _VERIFY(status) + call MAPL_FieldGetPointer(yfield,yptr2d,rc=status) + _VERIFY(status) + else + allocate(xptr2d(0,0)) + allocate(yptr2d(0,0)) + end if + + if (hasDE_in) then + call MAPL_FieldGetPointer(xOutField,xoutptr2d,rc=status) + _VERIFY(status) + call MAPL_FieldGetPointer(yOutField,youtptr2d,rc=status) + _VERIFY(status) + else + allocate(xoutptr2d(0,0)) + allocate(youtptr2d(0,0)) + end if + + + if (gridIn==gridOut) then + xoutPtr2d=xptr2d + youtPtr2d=yptr2d + else + call this%regrid_handle%regrid(xptr2d,yptr2d,xoutPtr2d,youtPtr2d,rc=status) + _VERIFY(status) + end if + else if (fieldRank==3) then + if (.not.associated(xptr3d)) then + if (hasDE_in) then + call MAPL_FieldGetPointer(xfield,xptr3d,rc=status) + _VERIFY(status) + else + allocate(xptr3d(0,0,0)) + end if + end if + if (.not.associated(yptr3d)) then + if (hasDE_in) then + call MAPL_FieldGetPointer(yfield,yptr3d,rc=status) + _VERIFY(status) + else + allocate(yptr3d(0,0,0)) + end if + end if + + if (hasDE_out) then + call MAPL_FieldGetPointer(xOutField,xoutptr3d,rc=status) + _VERIFY(status) + call MAPL_FieldGetPointer(yOutField,youtptr3d,rc=status) + _VERIFY(status) + else + allocate(xoutptr3d(0,0,0)) + allocate(youtptr3d(0,0,0)) + end if + + if (gridIn==gridOut) then + xoutPtr3d=xptr3d + youtPtr3d=yptr3d + else + call this%regrid_handle%regrid(xptr3d,yptr3d,xoutPtr3d,youtPtr3d,rc=status) + _VERIFY(status) + end if + end if + + if (allocated(xptr3d_inter)) deallocate(xptr3d_inter) + if (allocated(yptr3d_inter)) deallocate(yptr3d_inter) + _RETURN(_SUCCESS) + + end subroutine RegridVector + + + subroutine alphabatize_variables(this,nfixedVars,rc) + class (sampler), intent(inout) :: this + integer, intent(in) :: nFixedVars + integer, optional, intent(out) :: rc + + type(StringVector) :: order + type(StringVector) :: newOrder + character(len=:), pointer :: v1 + character(len=ESMF_MAXSTR) :: c1,c2 + character(len=ESMF_MAXSTR), allocatable :: temp(:) + logical :: swapped + integer :: n,i + integer :: status + + order = this%metadata%get_order(rc=status) + _VERIFY(status) + n = Order%size() + allocate(temp(nFixedVars+1:n)) + do i=1,n + v1 => order%at(i) + if ( i > nFixedVars) temp(i)=trim(v1) + enddo + + swapped = .true. + do while(swapped) + swapped = .false. + do i=nFixedVars+1,n-1 + c1 = temp(i) + c2 = temp(i+1) + if (c1 > c2) then + temp(i+1)=c1 + temp(i)=c2 + swapped =.true. + end if + enddo + enddo + + do i=1,nFixedVars + v1 => Order%at(i) + call newOrder%push_back(v1) + enddo + do i=nFixedVars+1,n + call newOrder%push_back(trim(temp(i))) + enddo + call this%metadata%set_order(newOrder,rc=status) + _VERIFY(status) + deallocate(temp) + + _RETURN(_SUCCESS) + + end subroutine alphabatize_variables + + + subroutine addVariable_to_acc_bundle(this,itemName,rc) + class (sampler), intent(inout) :: this + character(len=*), intent(in) :: itemName + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field,newField + integer :: fieldRank + integer :: status + + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) + call ESMF_FieldGet(field,rank=fieldRank,rc=status) + if (this%doVertRegrid .and. (fieldRank ==3) ) then + newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) + else + newField = MAPL_FieldCreate(field,this%output_grid,_RC) + end if + call MAPL_FieldBundleAdd(this%acc_bundle,newField,_RC) + + _RETURN(_SUCCESS) + + end subroutine addVariable_to_acc_bundle + + + subroutine addVariable_to_output_bundle(this,itemName,rc) + class (sampler), intent(inout) :: this + character(len=*), intent(in) :: itemName + integer, optional, intent(out) :: rc + + type(ESMF_Field) :: field,newField + integer :: fieldRank + integer :: status + + call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) + call ESMF_FieldGet(field,rank=fieldRank,rc=status) + if (this%doVertRegrid .and. (fieldRank ==3) ) then + newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) + else + newField = MAPL_FieldCreate(field,this%output_grid,_RC) + end if + call MAPL_FieldBundleAdd(this%output_bundle,newField,_RC) + + _RETURN(_SUCCESS) + end subroutine addVariable_to_output_bundle + + + + !! -- based on subroutine bundlepost(this,filename,oClients,rc) + !! + subroutine interp_accumulate_fields (this,xy_subset,rc) + implicit none + class (sampler) :: this + integer, intent(in) :: xy_subset(2,2) + !!integer, intent(in) :: xy_mask(:,:) + integer, optional, intent(out) :: rc + + integer :: status + type(ESMF_Field) :: outField + type(ESMF_Field) :: new_outField + type(ESMF_Grid) :: grid + + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + + type(ESMF_Array) :: array1, array2 + integer :: is,ie,js,je + + integer :: rank + real(KIND=ESMF_KIND_R4), pointer :: pt2d(:,:), pt2d_(:,:) + real(KIND=ESMF_KIND_R4), pointer :: pt3d(:,:,:), pt3d_(:,:,:) + + integer :: localDe, localDECount + integer, dimension(:), allocatable :: LB, UB, exclusiveCount + integer, dimension(:), allocatable :: compLB, compUB, compCount + integer :: dimCount + integer :: y1, y2 + integer :: j, jj + integer :: ii1, iin, jj1, jjn + integer, dimension(:), allocatable :: j1, j2 + + is=xy_subset(1,1); ie=xy_subset(2,1) + js=xy_subset(1,2); je=xy_subset(2,2) + + if (js > je) then + ! no valid points are found on swath grid for this time step + _RETURN(ESMF_SUCCESS) + end if + + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%setup_eta_to_pressure(regrid_handle=this%regrid_handle,output_grid=this%output_grid,rc=status) + _VERIFY(status) + end if + + call ESMF_FieldBundleGet(this%output_bundle, grid=grid, _RC) + call ESMF_GridGet(grid, localDECount=localDECount, dimCount=dimCount, _RC) + allocate ( LB(dimCount), UB(dimCount), exclusiveCount(dimCount) ) + allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) + + allocate ( j1(0:localDEcount-1) ) ! start + allocate ( j2(0:localDEcount-1) ) ! end + + _ASSERT ( localDEcount == 1, 'failed, due to localDEcount > 1') + call MAPL_GridGetInterior(grid,ii1,iin,jj1,jjn) +!! write(6,*) 'MAPL_GridGetInterior, ii1,iin,jj1,jjn', ii1,iin,jj1,jjn +!! print*, 'js,je ', js, je + + LB(1)=ii1; LB(2)=jj1 + UB(1)=iin; UB(2)=jjn + + do localDe=0, localDEcount-1 + ! + ! is/ie, js/je, [LB, UB] + ! + ! + y1=jj1; y2=jjn + if (y1 < js) then + if (y2 < js) then + j1(localDe)=-1 + j2(localDe)=-1 + elseif (y2 < je) then + j1(localDe)=js + j2(localDe)=y2 + else + j1(localDe)=js + j2(localDe)=je + endif + elseif (y1 <= je) then + j1(localDe)=y1 + if (y2 < je) then + j2(localDe)=y2 + else + j2(localDe)=je + endif + else + j1(localDe)=-1 + j2(localDe)=-1 + endif + enddo + +!! write(6,*) 'ck bundlepost_acc' +!! write(6,*) 'j1(localDe)', j1(0:localDeCount-1) +!! write(6,*) 'j2(localDe)', j2(0:localDeCount-1) + + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call this%RegridScalar(item%xname,rc=status) + _VERIFY(status) + call ESMF_FieldBundleGet(this%output_bundle,item%xname,field=outField, _RC) + _VERIFY(status) + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%correct_topo(outField,rc=status) + _VERIFY(status) + end if + + ! -- mask the time interval + ! store the time interval fields into new bundle + call ESMF_FieldGet(outField, Array=array1, _RC) + call ESMF_FieldBundleGet(this%acc_bundle,item%xname,field=new_outField,_RC) + call ESMF_FieldGet(new_outField, Array=array2, _RC) + call ESMF_ArrayGet(array1, rank=rank, _RC) + if (rank==2) then + call ESMF_ArrayGet(array1, farrayptr=pt2d, _RC) + call ESMF_ArrayGet(array2, farrayptr=pt2d_, _RC) + localDe=0 + if (j1(localDe)>0) then + do j= j1(localDe), j2(localDe) + jj= j-jj1+1 ! j_local +!! write(6,*) 'j, jj', j, jj + pt2d_(:,jj) = pt2d(:,jj) + enddo + endif + elseif (rank==3) then + call ESMF_ArrayGet(array1, farrayptr=pt3d, _RC) + call ESMF_ArrayGet(array2, farrayptr=pt3d_, _RC) + do localDe=0, localDEcount-1 + if (j1(localDe)>0) then + do j= j1(localDe), j2(localDe) + jj= j-jj1+1 + pt3d_(:,jj,:) = pt3d(:,jj,:) + enddo + endif + enddo + else + _FAIL('failed interp_accumulate_fields') + endif + + else if (item%itemType == ItemTypeVector) then + _FAIL('ItemTypeVector not implemented') + end if + call iter%next() + enddo + + _RETURN(ESMF_SUCCESS) + + end subroutine interp_accumulate_fields + + + subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) + implicit none + type(ESMF_Grid), intent(in) :: grid + integer, intent(in) :: xy_subset(2,2) + integer, intent(out) :: xy_mask(:,:) + integer, optional, intent(out) :: rc + + integer :: status + integer :: ii1, iin, jj1, jjn ! local box for localDE + integer :: is,ie, js, je ! global box for each time-interval + + integer :: y1, y2 + integer :: jj + integer :: j1, j2 + + is=xy_subset(1,1); ie=xy_subset(2,1) + js=xy_subset(1,2); je=xy_subset(2,2) + + call MAPL_GridGetInterior(grid,ii1,iin,jj1,jjn) + write(6,*) 'MAPL_GridGetInterior, ii1,iin,jj1,jjn', ii1,iin,jj1,jjn + + y1=jj1; y2=jjn + if (y1 < js) then + if (y2 < js) then + j1=-1 + j2=-1 + elseif (y2 < je) then + j1=js + j2=y2 + else + j1=js + j2=je + endif + elseif (y1 <= je) then + j1=y1 + if (y2 < je) then + j2=y2 + else + j2=je + endif + else + j1=-1 + j2=-1 + endif + +!! write(6,*) 'get_xy_mask: j1,j2=', j1, j2 + xy_mask(:,:) = 0 + if (j1 > 0) then + do jj = j1, j2 + xy_mask(:, jj) = 1 + enddo + end if + + if(present(rc)) rc=0 + + end subroutine get_xy_mask + + +end module MAPL_EpochSwathMod diff --git a/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 b/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 new file mode 100644 index 000000000000..69a83a0ac979 --- /dev/null +++ b/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 @@ -0,0 +1,179 @@ +module MaskSamplerGeosatMod + use ESMF + use MAPL_ErrorHandlingMod + use MAPL_KeywordEnforcerMod + use LocStreamFactoryMod + use MAPL_LocstreamRegridderMod + use MAPL_FileMetadataUtilsMod + use pFIO + use MAPL_GriddedIOItemMod + use MAPL_GriddedIOItemVectorMod + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_BaseMod + use MAPL_CommsMod + use MAPL_SortMod + use MAPL_NetCDF + use MAPL_StringTemplate + use Plain_netCDF_Time + use MAPL_ObsUtilMod + use MPI + use pFIO_FileMetadataMod, only : FileMetadata + use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter + use, intrinsic :: iso_fortran_env, only: REAL32 + use, intrinsic :: iso_fortran_env, only: REAL64 + use pflogger, only: Logger, logging + implicit none + + private + + public :: MaskSamplerGeosat + type :: MaskSamplerGeosat + private + ! character(len=:), allocatable :: grid_file_name + character(len=ESMF_MAXSTR) :: grid_file_name + !-- ygyu we donot need LS + ! + ! we need on each PET + ! npt_mask, index_mask(1:2,npt_mask)=[i,j] + ! + integer :: npt_mask + integer :: npt_mask_tot + integer, allocatable :: index_mask(:,:) + ! + type(ESMF_FieldBundle) :: bundle + type(ESMF_FieldBundle) :: output_bundle + ! type(ESMF_FieldBundle) :: acc_bundle + ! type(ESMF_Field) :: fieldA + ! type(ESMF_Field) :: fieldB + + type(GriddedIOitemVector) :: items + type(VerticalData) :: vdata + logical :: do_vertical_regrid + character(len=ESMF_MAXSTR) :: ofile + type(TimeData) :: time_info + type(ESMF_Clock) :: clock + type(ESMF_Alarm), public :: alarm + type(ESMF_Time) :: RingTime + type(ESMF_TimeInterval) :: epoch_frequency + type(FileMetadata) :: metadata + type(NetCDF4_FileFormatter) :: formatter + + + integer :: nobs_type + integer :: nobs + integer :: obs_written + + character(len=ESMF_MAXSTR) :: index_name_x + character(len=ESMF_MAXSTR) :: index_name_y + character(len=ESMF_MAXSTR) :: index_name_location + character(len=ESMF_MAXSTR) :: index_name_lon + character(len=ESMF_MAXSTR) :: index_name_lat + character(len=ESMF_MAXSTR) :: index_name_loc + character(len=ESMF_MAXSTR) :: var_name_time + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_x + character(len=ESMF_MAXSTR) :: var_name_y + character(len=ESMF_MAXSTR) :: var_name_proj + character(len=ESMF_MAXSTR) :: att_name_proj + + integer :: xdim_true + integer :: ydim_true + integer :: thin_factor + + integer :: epoch ! unit: second + integer(kind=ESMF_KIND_I8) :: epoch_index(2) + real(kind=REAL64), allocatable :: lons(:) + real(kind=REAL64), allocatable :: lats(:) + integer, allocatable :: recvcounts(:) + integer, allocatable :: displs(:) + + real(kind=ESMF_KIND_R8), pointer:: obsTime(:) + real(kind=ESMF_KIND_R8), allocatable:: t_alongtrack(:) + integer :: nobs_dur + integer :: nobs_dur_sum + type(ESMF_Time) :: obsfile_start_time ! user specify + type(ESMF_Time) :: obsfile_end_time + type(ESMF_TimeInterval) :: obsfile_interval + integer :: obsfile_Ts_index ! for epoch + integer :: obsfile_Te_index + logical :: is_valid + contains + procedure :: initialize + procedure :: add_metadata + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file => regrid_accumulate_append_file +! procedure :: create_new_bundle + procedure :: create_grid => create_Geosat_grid_find_mask + procedure :: compute_time_for_current + end type MaskSamplerGeosat + + interface MaskSamplerGeosat + module procedure MaskSamplerGeosat_from_config + end interface MaskSamplerGeosat + + + interface + module function MaskSamplerGeosat_from_config(config,string,clock,rc) result(mask) + type(MaskSamplerGeosat) :: mask + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: string + type(ESMF_Clock), intent(in) :: clock + integer, optional, intent(out) :: rc + end function MaskSamplerGeosat_from_config + + module subroutine initialize(this,items,bundle,timeInfo,vdata,reinitialize,rc) + class(MaskSamplerGeosat), intent(inout) :: this + type(GriddedIOitemVector), optional, intent(inout) :: items + type(ESMF_FieldBundle), optional, intent(inout) :: bundle + type(TimeData), optional, intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + logical, optional, intent(in) :: reinitialize + integer, optional, intent(out) :: rc + end subroutine initialize + + module subroutine create_Geosat_grid_find_mask(this, rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine create_Geosat_grid_find_mask + +!! module function create_new_bundle(this,rc) result(new_bundle) +!! class(MaskSamplerGeosat), intent(inout) :: this +!! type(ESMF_FieldBundle) :: new_bundle +!! integer, optional, intent(out) :: rc +!! end function create_new_bundle + + !! module subroutine add_metadata(this,currTime,rc) + module subroutine add_metadata(this,rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine add_metadata + + module subroutine create_file_handle(this,filename,rc) + class(MaskSamplerGeosat), intent(inout) :: this + character(len=*), intent(in) :: filename + integer, optional, intent(out) :: rc + end subroutine create_file_handle + + module subroutine close_file_handle(this,rc) + class(MaskSamplerGeosat), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine close_file_handle + + module subroutine regrid_accumulate_append_file(this,current_time,rc) + class(MaskSamplerGeosat), intent(inout) :: this + type(ESMF_Time), intent(inout) :: current_time + integer, optional, intent(out) :: rc + end subroutine regrid_accumulate_append_file + + module function compute_time_for_current(this,current_time,rc) result(rtime) + class(MaskSamplerGeosat), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + real(kind=ESMF_KIND_R8) :: rtime + end function compute_time_for_current + + end interface +end module MaskSamplerGeosatMod diff --git a/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 b/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 new file mode 100644 index 000000000000..3013c4f313ef --- /dev/null +++ b/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 @@ -0,0 +1,751 @@ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +submodule (MaskSamplerGeosatMod) MaskSamplerGeosat_implement + implicit none +contains + + module procedure MaskSamplerGeosat_from_config + use BinIOMod + use pflogger, only : Logger, logging + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: epoch_frequency + type(ESMF_TimeInterval) :: obs_time_span + integer :: time_integer, second + integer :: status + character(len=ESMF_MAXSTR) :: STR1, line + character(len=ESMF_MAXSTR) :: symd, shms + integer :: nline, col + integer, allocatable :: ncol(:) + character(len=ESMF_MAXSTR), allocatable :: word(:) + integer :: nobs, head, jvar + logical :: tend + integer :: i, j, k, M + integer :: count + integer :: unitr, unitw + type(Logger), pointer :: lgr + + mask%clock=clock + mask%grid_file_name='' + call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) + if (mapl_am_I_root()) write(6,*) 'string', string + + + call ESMF_ConfigGetAttribute(config, value=mask%grid_file_name,label=trim(string)//'obs_files:', default="", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%index_name_x, label=trim(string)//'index_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%index_name_y, label=trim(string)//'index_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%var_name_x, label=trim(string)//'var_name_x:', default="x", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%var_name_y, label=trim(string)//'var_name_y:', default="y", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%var_name_proj, label=trim(string)//'var_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%att_name_proj, label=trim(string)//'att_name_proj:',default="", _RC) + call ESMF_ConfigGetAttribute(config, value=mask%thin_factor, label=trim(string)//'thin_factor:', default=-1, _RC) + + + if (mapl_am_I_root()) write(6,*) 'thin_factor:', mask%thin_factor + call ESMF_ConfigGetAttribute(config, value=STR1, label=trim(string)//'obs_file_begin:', default="", _RC) + if (trim(STR1)=='') then + mask%obsfile_start_time = currTime + call ESMF_TimeGet(currTime, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) + endif + else + call ESMF_TimeSet(mask%obsfile_start_time, STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin provided: ', trim(STR1) + end if + end if + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_end:', _RC) + if (trim(STR1)=='') then + call ESMF_TimeIntervalSet(obs_time_span, d=14, _RC) + mask%obsfile_end_time = mask%obsfile_start_time + obs_time_span + call ESMF_TimeGet(mask%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end missing, default = begin+14D:', trim(STR1) + endif + else + call ESMF_TimeSet(mask%obsfile_end_time, STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end provided:', trim(STR1) + end if + end if + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_interval:', _RC) + _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') + if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) + + + i= index( trim(STR1), ' ' ) + if (i>0) then + symd=STR1(1:i-1) + shms=STR1(i+1:) + else + symd='' + shms=trim(STR1) + endif + call convert_twostring_2_esmfinterval (symd, shms, mask%obsfile_interval, _RC) + + mask%is_valid = .true. + + _RETURN(_SUCCESS) + +105 format (1x,a,2x,a) +106 format (1x,a,2x,i8) + end procedure MaskSamplerGeosat_from_config + + + ! + !-- integrate both initialize and reinitialize + ! + module procedure initialize + integer :: status + type(ESMF_Grid) :: grid + type(variable) :: v + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_Time) :: currTime + integer :: k + + if (.not. present(reinitialize)) then + if(present(bundle)) this%bundle=bundle + if(present(items)) this%items=items + if(present(timeInfo)) this%time_info=timeInfo + if (present(vdata)) then + this%vdata=vdata + else + this%vdata=VerticalData(_RC) + end if + end if + +! this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) +! if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) + + this%ofile = '' + this%obs_written = 0 + + call this%create_grid(_RC) + call this%add_metadata(_RC) + + _RETURN(_SUCCESS) + + end procedure initialize + + + module procedure create_Geosat_grid_find_mask + use pflogger, only: Logger, logging + implicit none + type(Logger), pointer :: lgr + real(ESMF_KIND_R8), pointer :: ptAT(:) + type(ESMF_routehandle) :: RH + type(ESMF_Grid) :: grid + integer :: mypet, npes + integer :: iroot, rootpet, ierr + type (ESMF_LocStream) :: LS_rt + type (ESMF_LocStream) :: LS_ds + type (LocStreamFactory):: locstream_factory + type (ESMF_Field) :: fieldA + type (ESMF_Field) :: fieldB + + integer :: i, j, k, L + integer :: n1, n2 + integer :: nx, ny, nx_sum + integer :: nlon, nlat + integer :: arr(1) + integer :: len + + integer :: IM, JM, LM, COUNTS(3) + type(ESMF_DistGrid) :: distGrid + type(ESMF_DElayout) :: layout + type(ESMF_VM) :: VM + integer :: myid + integer :: ndes + integer :: dimCount + integer, allocatable :: II(:) + integer, allocatable :: JJ(:) + real(REAL64), allocatable :: obs_lons(:) + real(REAL64), allocatable :: obs_lats(:) + integer :: mpic + + type (ESMF_Field) :: fieldI4 + type(ESMF_routehandle) :: RH_halo + type(ESMF_Field) :: src_field,dst_field,acc_field + integer :: useableHalo_width + integer :: rank + integer :: eLB(2), eUB(2) + integer :: cLB(2), cUB(2) + integer :: tLB(2), tUB(2) + integer :: ecount(2) + integer :: ccount(2) + integer :: tcount(2) + integer(ESMF_KIND_I4), pointer :: farrayPtr(:,:) + real(ESMF_KIND_R8), pointer :: ptA(:) => NULL() + real(ESMF_KIND_R8), pointer :: ptB(:) => NULL() + + character(len=50) :: filename + integer :: unit + integer :: ix, jx + integer :: i_1, i_n, j_1, j_n + real(REAL64), pointer :: x(:) + real(REAL64), pointer :: y(:) + real(REAL64) :: lambda0_deg, lambda0 + real(REAL64) :: x0, y0 + real(REAL64) :: lon0, lat0 + real(REAL64) :: lam_sat + integer :: mask0 + character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att + integer :: Xdim_true, Ydim_true + integer :: Xdim_red, Ydim_red + real(REAL64), allocatable :: lons(:), lats(:) + real(REAL64), allocatable :: lons_ds(:), lats_ds(:) + integer, allocatable :: mask(:,:) + + real(ESMF_kind_R8), pointer :: lons_ptr(:,:), lats_ptr(:,:) + integer :: nsend + integer, allocatable :: recvcounts_loc(:) + integer, allocatable :: displs_loc(:) + integer :: status + + lgr => logging%get_logger('HISTORY.sampler') + + ! Metacode: + ! read ABI grid into LS_rt + ! gen LS_ds with CS background grid + ! find mask points on each PET with halo + ! prepare recvcounts + displs for gatherv + ! + + if (mapl_am_i_root()) then + ! __s1. SAT file + ! + fn = this%grid_file_name + key_x = this%var_name_x + key_y = this%var_name_y + key_p = this%var_name_proj + key_p_att = this%att_name_proj + call get_ncfile_dimension(fn,nlon=n1,nlat=n2,key_lon=key_x,key_lat=key_y,_RC) + ! + ! use thin_factor to reduce regridding matrix size + ! + xdim_true = n1 + ydim_true = n2 + xdim_red = n1 / this%thin_factor + ydim_red = n2 / this%thin_factor + allocate (x (xdim_true) ) + allocate (y (xdim_true) ) + + call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) + call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) + call get_att_real_netcdf (fn, key_p, key_p_att, lambda0_deg, _RC) + lam_sat = lambda0_deg * MAPL_DEGREES_TO_RADIANS_R8 + + nx=0 + do i=1, xdim_red + do j=1, ydim_red + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) + call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) + if (mask0 > 0) then + nx=nx+1 + end if + end do + end do + allocate (lons(nx), lats(nx)) + nx = 0 + do i=1, xdim_red + do j=1, ydim_red + x0 = x( i * this%thin_factor ) + y0 = y( j * this%thin_factor ) + call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) + if (mask0 > 0) then + nx=nx+1 + lons(nx) = lon0 * MAPL_RADIANS_TO_DEGREES + lats(nx) = lat0 * MAPL_RADIANS_TO_DEGREES + end if + end do + end do + arr(1)=nx + else + allocate(lons(0),lats(0),_STAT) + arr(1)=0 + endif + + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petcount=npes, localpet=mypet, _RC) + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx, & + count=1, reduceflag=ESMF_REDUCE_SUM, _RC) + this%nobs = nx + if (mapl_am_I_root()) write(6,*) 'nobs tot :', nx + + if ( nx == 0 ) then + this%is_valid = .false. + _RETURN(ESMF_SUCCESS) + ! + ! no valid obs points are found + ! + end if + + + ! __ s2. set distributed LS + ! + locstream_factory = LocStreamFactory(lons,lats,_RC) + LS_rt = locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + LS_ds = locstream_factory%create_locstream(grid=grid,_RC) + + fieldA = ESMF_FieldCreate (LS_rt, name='A', typekind=ESMF_TYPEKIND_R8, _RC) + fieldB = ESMF_FieldCreate (LS_ds, name='B', typekind=ESMF_TYPEKIND_R8, _RC) + + call ESMF_FieldGet( fieldA, localDE=0, farrayPtr=ptA) + call ESMF_FieldGet( fieldB, localDE=0, farrayPtr=ptB) + if (mypet == 0) then + ptA(:) = lons(:) + end if + call ESMF_FieldRedistStore (fieldA, fieldB, RH, _RC) + call ESMF_FieldRedist (fieldA, fieldB, RH, _RC) + lons_ds = ptB + + if (mypet == 0) then + ptA(:) = lats(:) + end if + call ESMF_FieldRedist (fieldA, fieldB, RH, _RC) + lats_ds = ptB + + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + call ESMF_FieldDestroy(fieldA,nogarbage=.true.,_RC) + call ESMF_FieldDestroy(fieldB,nogarbage=.true.,_RC) + + + ! __ s3. find n.n. CS pts for LS_ds (halo) + ! + obs_lons = lons_ds * MAPL_DEGREES_TO_RADIANS_R8 + obs_lats = lats_ds * MAPL_DEGREES_TO_RADIANS_R8 + nx = size ( lons_ds ) + allocate ( II(nx), JJ(nx) ) + call MPI_Barrier(mpic, status) + call MAPL_GetHorzIJIndex(nx,II,JJ,lonR8=obs_lons,latR8=obs_lats,grid=grid,_RC) + call ESMF_VMBarrier (vm, _RC) + + ! + ! __ halo for mask + ! + call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, _RC) + IM= COUNTS(1) + JM= COUNTS(2) + LM= COUNTS(3) + useableHalo_width = 1 + fieldI4 = ESMF_FieldCreate (grid, ESMF_TYPEKIND_I4, & + totalLwidth=[useableHalo_width,useableHalo_width],& + totalUwidth=[useableHalo_width,useableHalo_width], _RC) + call ESMF_FieldGetBounds (fieldI4, & + exclusiveLBound=eLB, exclusiveUBound=eUB, exclusiveCount=ecount, & + totalLBound=tLB, totalUBound=tUB, totalCount=tcount, & + computationalLBound=cLB, computationalUBound=cUB, computationalCount=ccount, & + _RC) + call ESMF_FieldGet (fieldI4, farrayPtr=farrayPtr, _RC) + farrayPtr(:,:) = 0 + do i=1, nx + if ( II(i)>0 .AND. JJ(i)>0 ) then + farrayPtr( II(i), JJ(i) ) = 1 + endif + enddo + + call ESMF_FieldHaloStore (fieldI4, routehandle=RH_halo, _RC) + call ESMF_FieldHalo (fieldI4, routehandle=RH_halo, _RC) + call ESMF_VMBarrier (vm, _RC) + + k=0 + do i=eLB(1), eUB(1) + do j=eLB(2), eUB(2) + if ( farrayPtr(i,j)==0 .AND. ( & + farrayPtr(i-1,j)==1 .OR. & + farrayPtr(i+1,j)==1 .OR. & + farrayPtr(i,j-1)==1 .OR. & + farrayPtr(i,j+1)==1 ) ) then + farrayPtr(i,j) = -1 + end if + if (farrayPtr(i,j)/=0) k=k+1 + end do + end do + allocate( mask(IM, JM)) + mask(1:IM, 1:JM) = abs(farrayPtr(1:IM, 1:JM)) + + this%npt_mask = k + allocate( this%index_mask(2,k) ) + arr(1)=k + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=this%npt_mask_tot, & + count=1, reduceflag=ESMF_REDUCE_SUM, _RC) + + k=0 + do i=1, IM + do j=1, JM + if ( mask(i,j)==1 ) then + k=k+1 + this%index_mask(1,k) = i + this%index_mask(2,k) = j + end if + end do + end do + + + ! ---- + ! regridding is replaced by + ! - selecting masked data on PET + ! - mpi_gatherV + ! + + + ! __ s4.1 find this%lons/lats on root for NC output + ! + call ESMF_GridGetCoord (grid, coordDim=1, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lons_ptr, _RC) + call ESMF_GridGetCoord (grid, coordDim=2, localDE=0, & + staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lats_ptr, _RC) + deallocate (lons, lats) + allocate (lons(this%npt_mask), lats(this%npt_mask)) + do i=1, this%npt_mask + ix=this%index_mask(1,i) + jx=this%index_mask(2,i) + lons(i) = lons_ptr (ix, jx) + lats(i) = lats_ptr (ix, jx) + end do + call ESMF_VMBarrier (vm, _RC) + + iroot=0 + if (mapl_am_i_root()) then + allocate (this%lons(this%npt_mask_tot), this%lats(this%npt_mask_tot)) + else + allocate (this%lons(0), this%lats(0)) + end if + + + ! __ s4.2 find this%recvcounts / this%displs + ! + allocate( this%recvcounts(npes), this%displs(npes) ) + allocate( recvcounts_loc(npes), displs_loc(npes) ) + recvcounts_loc(:)=1 + displs_loc(1)=0 + do i=2, npes + displs_loc(i) = displs_loc(i-1) + recvcounts_loc(i-1) + end do + call MPI_gatherv ( this%npt_mask, 1, MPI_INTEGER, & + this%recvcounts, recvcounts_loc, displs_loc, MPI_INTEGER,& + iroot, mpic, ierr ) + if (.not. mapl_am_i_root()) then + this%recvcounts(:) = 0 + end if + this%displs(1)=0 + do i=2, npes + this%displs(i) = this%displs(i-1) + this%recvcounts(i-1) + end do + + + ! __ s4.3 gatherv lons/lats + ! + nsend=this%npt_mask + call MPI_gatherv ( lons, nsend, MPI_REAL8, & + this%lons, this%recvcounts, this%displs, MPI_REAL8,& + iroot, mpic, ierr ) + call MPI_gatherv ( lats, nsend, MPI_REAL8, & + this%lats, this%recvcounts, this%displs, MPI_REAL8,& + iroot, mpic, ierr ) + + _RETURN(_SUCCESS) + end procedure create_Geosat_grid_find_mask + + +module procedure add_metadata + type(variable) :: v + type(ESMF_Field) :: field + integer :: fieldCount + integer :: field_rank + integer :: nstation + logical :: is_present + integer :: ub(ESMF_MAXDIM) + integer :: lb(ESMF_MAXDIM) + logical :: do_vertical_regrid + integer :: status + integer :: i + + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims + character(len=40) :: datetime_units + + !__ 1. metadata add_dimension, + ! add_variable for time, latlon, mask_points + ! + call this%vdata%append_vertical_metadata(this%metadata,this%bundle,_RC) ! specify lev in fmd + call this%time_info%add_time_to_metadata(this%metadata,_RC) + call this%metadata%add_dimension('mask_index', this%npt_mask_tot) + + v = Variable(type=pFIO_REAL64, dimensions='mask_index') + call v%add_attribute('long_name','longitude') + call v%add_attribute('unit','degree_east') + call this%metadata%add_variable('longitude',v) + + v = Variable(type=pFIO_REAL64, dimensions='mask_index') + call v%add_attribute('long_name','latitude') + call v%add_attribute('unit','degree_north') + call this%metadata%add_variable('latitude',v) + + ! To be added when values are available + !v = Variable(type=pFIO_INT32, dimensions='mask_index') + !call v%add_attribute('long_name','The Cubed Sphere Global Face ID') + !call this%metadata%add_variable('mask_CS_Face_ID',v) + ! + !v = Variable(type=pFIO_INT32, dimensions='mask_index') + !call v%add_attribute('long_name','The Cubed Sphere Global Index I') + !call this%metadata%add_variable('mask_CS_global_index_I',v) + ! + !v = Variable(type=pFIO_INT32, dimensions='mask_index') + !call v%add_attribute('long_name','The Cubed Sphere Global Index J') + !call this%metadata%add_variable('mask_CS_global_index_J',v) + + + !__ 2. filemetadata: extract field from bundle, add_variable to metadata + ! + call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + var_name=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(this%bundle,var_name,field=field,_RC) + call ESMF_FieldGet(field,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) + else + long_name = var_name + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) + else + units = 'unknown' + endif + if (field_rank==2) then + vdims = "mask_index,time" + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[this%npt_mask_tot,1]) + else if (field_rank==3) then + vdims = "lev,mask_index,time" + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + end if + call v%add_attribute('units', trim(units)) + call v%add_attribute('long_name', trim(long_name)) + call v%add_attribute('missing_value', MAPL_UNDEF) + call v%add_attribute('_FillValue', MAPL_UNDEF) + call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) + call this%metadata%add_variable(trim(var_name),v,_RC) + end do + deallocate (fieldNameList) + + _RETURN(_SUCCESS) + end procedure add_metadata + + + module procedure regrid_accumulate_append_file + ! + implicit none + integer :: status + integer :: fieldCount + integer :: ub(1), lb(1) + type(ESMF_Field) :: src_field,dst_field + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(kind=REAL32), allocatable :: p_dst_3d(:),p_dst_2d(:) + real(kind=REAL32), allocatable :: p_dst_3d_full(:),p_dst_2d_full(:) + real(kind=REAL32), allocatable :: arr(:,:) + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: xname + real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i, j, k, rank + integer :: nx, nz + integer :: ix, iy, m + integer :: mypet, npes, nsend + integer :: iroot, ierr + integer :: mpic + integer, allocatable :: recvcounts_3d(:) + integer, allocatable :: displs_3d(:) + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_VM) :: vm + + this%obs_written=this%obs_written+1 + + ! -- fixed for all fields + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petcount=npes, localpet=mypet, _RC) + iroot=0 + nx = this%npt_mask + nz = this%vdata%lm + allocate(p_dst_2d (nx)) + allocate(p_dst_3d (nx * nz)) + if (mapl_am_i_root()) then + allocate ( p_dst_2d_full (this%npt_mask_tot) ) + allocate ( p_dst_3d_full (this%npt_mask_tot * nz) ) + else + allocate ( p_dst_2d_full (0) ) + allocate ( p_dst_3d_full (0) ) + end if + allocate( recvcounts_3d(npes), displs_3d(npes) ) + recvcounts_3d(:) = nz * this%recvcounts(:) + displs_3d(:) = nz * this%displs(:) + + + !__ 1. put_var: time variable + ! + allocate( rtimes(1) ) + rtimes(1) = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file + if (mapl_am_i_root()) then + call this%formatter%put_var('time',rtimes(1:1),& + start=[this%obs_written],count=[1],_RC) + end if + + + !__ 2. put_var: ungridded_dim from src to dst [use index_mask] + ! + ! Currently mask only pickup values + ! It does not support vertical regridding + ! + !if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + ! call this%vdata%setup_eta_to_pressure(_RC) + !endif + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + do j=1, nx + ix = this%index_mask(1,j) + iy = this%index_mask(2,j) + p_dst_2d(j) = p_src_2d(ix, iy) + end do + call MPI_Barrier(mpic, status) + nsend = nx + call MPI_gatherv ( p_dst_2d, nsend, MPI_REAL, & + p_dst_2d_full, this%recvcounts, this%displs, MPI_REAL,& + iroot, mpic, ierr ) + if (mapl_am_i_root()) then + call this%formatter%put_var(item%xname,p_dst_2d_full,& + start=[1,this%obs_written],count=[this%npt_mask_tot,1],_RC) + end if + else if (rank==3) then + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + _ASSERT (this%vdata%lm == (ub(1)-lb(1)+1), 'vertical level is different from CS grid') + m=0 + do j=1, nx + ix = this%index_mask(1,j) + iy = this%index_mask(2,j) + do k= lb(1), ub(1) + m = m + 1 + p_dst_3d(m) = p_src_3d(ix, iy, k) + end do + end do + call MPI_Barrier(mpic, status) + !! write(6,'(2x,a,2x,i5,3x,10f8.1)') 'pet, p_dst_3d(j)', mypet, p_dst_3d(::10) + nsend = nx * nz + call MPI_gatherv ( p_dst_3d, nsend, MPI_REAL, & + p_dst_3d_full, recvcounts_3d, displs_3d, MPI_REAL,& + iroot, mpic, ierr ) + if (mapl_am_i_root()) then + allocate(arr(nz, this%npt_mask_tot)) + arr=reshape(p_dst_3d_full,[nz,this%npt_mask_tot],order=[1,2]) + call this%formatter%put_var(item%xname,arr,& + start=[1,1,this%obs_written],count=[nz,this%npt_mask_tot,1],_RC) + !note: lev,station,time + deallocate(arr) + end if + else + _FAIL('grid2LS regridder: rank > 3 not implemented') + end if + end if + + call iter%next() + end do + + _RETURN(_SUCCESS) + end procedure regrid_accumulate_append_file + + + + module procedure create_file_handle + type(variable) :: v + integer :: status, j + real(kind=REAL64), allocatable :: x(:) + integer :: nx + + this%ofile = trim(filename) + v = this%time_info%define_time_variable(_RC) + call this%metadata%modify_variable('time',v,_RC) + this%obs_written = 0 + + if (.not. mapl_am_I_root()) then + _RETURN(_SUCCESS) + end if + + call this%formatter%create(trim(filename),_RC) + call this%formatter%write(this%metadata,_RC) + + nx = size (this%lons) + allocate ( x(nx) ) + x(:) = this%lons(:) * MAPL_RADIANS_TO_DEGREES + call this%formatter%put_var('longitude',x,_RC) + x(:) = this%lats(:) * MAPL_RADIANS_TO_DEGREES + call this%formatter%put_var('latitude',x,_RC) +! call this%formatter%put_var('mask_id',this%mask_id,_RC) +! call this%formatter%put_var('mask_name',this%mask_name,_RC) + + _RETURN(_SUCCESS) + end procedure create_file_handle + + + module procedure close_file_handle + integer :: status + if (trim(this%ofile) /= '') then + if (mapl_am_i_root()) then + call this%formatter%close(_RC) + end if + end if + _RETURN(_SUCCESS) + end procedure close_file_handle + + + module procedure compute_time_for_current + use MAPL_NetCDF, only : convert_NetCDF_DateTime_to_ESMF + integer :: status + type(ESMF_TimeInterval) :: t_interval + class(Variable), pointer :: var + type(Attribute), pointer :: attr + class(*), pointer :: pTimeUnits + character(len=ESMF_MAXSTR) :: datetime_units + character(len=ESMF_MAXSTR) :: tunit + type(ESMF_time), allocatable :: esmf_time_1d(:) + real(kind=ESMF_KIND_R8), allocatable :: rtime_1d(:) + + var => this%metadata%get_variable('time',_RC) + attr => var%get_attribute('units') + ptimeUnits => attr%get_value() + select type(pTimeUnits) + type is (character(*)) + datetime_units = ptimeUnits + class default + _FAIL("Time unit must be character") + end select + allocate ( esmf_time_1d(1), rtime_1d(1) ) + esmf_time_1d(1)= current_time + call time_ESMF_to_real ( rtime_1d, esmf_time_1d, datetime_units, _RC ) + rtime = rtime_1d(1) + + _RETURN(_SUCCESS) + end procedure compute_time_for_current + + + +end submodule MaskSamplerGeosat_implement diff --git a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 new file mode 100644 index 000000000000..633ffe0e9847 --- /dev/null +++ b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 @@ -0,0 +1,631 @@ +#include "MAPL_Generic.h" +module StationSamplerMod + use ESMF + use MAPL_ErrorHandlingMod + use LocStreamFactoryMod + use pFIO + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_BaseMod + use MAPL_CommsMod + use MAPL_LocstreamRegridderMod + use, intrinsic :: iso_fortran_env, only: REAL32 + use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_c_binding, only: C_NULL_CHAR + implicit none + private + + public :: StationSampler + type :: StationSampler + private + type(LocStreamFactory) :: LSF + type(ESMF_LocStream) :: esmf_ls + type(LocstreamRegridder) :: regridder + integer :: nstation + integer, allocatable :: station_id(:) + character(len=ESMF_MAXSTR), allocatable :: station_name(:) + character(len=ESMF_MAXSTR), allocatable :: station_fullname(:) + real(kind=REAL64), allocatable :: lons(:) + real(kind=REAL64), allocatable :: lats(:) + real(kind=REAL64), allocatable :: elevs(:) + type(ESMF_FieldBundle) :: bundle + type(FileMetadata) :: fmd + type(NetCDF4_FileFormatter) :: formatter + type(VerticalData) :: vdata + type(TimeData) :: time_info + character(LEN=ESMF_MAXPATHLEN) :: ofile + integer :: obs_written + contains + procedure :: add_metadata_route_handle + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file + procedure :: get_file_start_time + procedure :: compute_time_for_current + end type StationSampler + + interface StationSampler + module procedure new_StationSampler_readfile + end interface StationSampler + +contains + + function new_StationSampler_readfile (filename,nskip_line, rc) result(sampler) + use pflogger, only : Logger, logging + implicit none + type(StationSampler) :: sampler + character(len=*), intent(in) :: filename + integer, optional, intent(in) :: nskip_line + integer, optional, intent(out) :: rc + + integer :: unit, ios, nstation, status + integer :: i, j, k, ncount + logical :: con1, con2 + character (len=1) :: CH1 + character (len=5) :: seq + character (len=100) :: line, line2 + integer :: nskip + type(Logger), pointer :: lgr + + !__ 1. read from station_id_file: static + ! plain text format: + ! ["name,lat,lon,elev"] or ["id,name,lat,lon,elev"] + ! ["name_short lat lon elev name_full"] + ! + + open(newunit=unit, file=trim(filename), form='formatted', & + access='sequential', status='old', _IOSTAT) + ios=0 + nstation=0 + nskip=0 + if (present(nskip_line)) then + nskip=nskip_line + end if + if (nskip>0) then + do i=1, nskip + read(unit, *) + end do + end if + read(unit, '(a100)', IOSTAT=ios) line + call count_substring(line, ',', ncount, _RC) + con1= (ncount>=2 .AND. ncount<=4).OR.(ncount==0) + _ASSERT(con1, 'string sequence in Aeronet file not supported') + if (ncount==0) then + seq='AFFFA' + elseif (ncount==2) then + seq='AFF' + elseif (ncount==3) then + seq='AFFF' + elseif (ncount==4) then + CH1=line(1:1) + con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') + con2= CH1>='0'.AND.CH1<='9' + if (con1) then + seq='AIFFF' + else + if (con2) then + seq='IAFFF' + else + _ASSERT(.false., 'string sequence in Aeronet file not supported') + end if + end if + end if + + rewind(unit) + if (nskip>0) then + do i=1, nskip + read(unit, *) + end do + end if + ios=0 + do while (ios==0) + read(unit, '(a100)', IOSTAT=ios) line + if (ios==0) nstation=nstation+1 + end do + sampler%nstation=nstation + allocate(sampler%station_id(nstation)) + allocate(sampler%station_name(nstation)) + allocate(sampler%station_fullname(nstation)) + allocate(sampler%lons(nstation)) + allocate(sampler%lats(nstation)) + allocate(sampler%elevs(nstation)) + + rewind(unit) + if (nskip>0) then + do i=1, nskip + read(unit, *) + end do + end if + do i=1, nstation + if(seq=='IAFFF') then + read(unit, *) & + sampler%station_id(i), & + sampler%station_name(i), & + sampler%lons(i), & + sampler%lats(i) + elseif(seq=='AIFFF') then + read(unit, *) & + sampler%station_name(i), & + sampler%station_id(i), & + sampler%lons(i), & + sampler%lats(i) + elseif(trim(seq)=='AFF' .OR. trim(seq)=='AFFF') then + !!write(6,*) 'i=', i + line='' + read(unit, '(a100)') line + !!write(6,*) 'line=', trim(line) + call CSV_read_line_with_CH_I_R(line, & + sampler%station_name(i), & + sampler%lons(i), & + sampler%lats(i), _RC) + sampler%station_id(i)=i + elseif(trim(seq)=='AFFFA') then + ! Ex: 'ZI000067991 -22.2170 30.0000 457.0 BEITBRIDGE 67991' + read(unit, *) & + sampler%station_name(i), & + sampler%lons(i), & + sampler%lats(i) + + sampler%station_id(i)=i + backspace(unit) + read(unit, '(a100)', IOSTAT=ios) line + j=index(line, '.', BACK=.true.) + line2=line(j+1:) + k=len(line2) + line='' + do j=1, k + CH1=line2(j:j) + con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') + if (con1) exit + enddo + read(line2(j:k), '(a100)') line + line2=trim(line) + k=len(line2) + line='' + do j=1, k + CH1=line2(j:j) + con1= (CH1>='0' .AND. CH1<='9') + if (con1) exit + enddo + if (j>k) j=k + sampler%station_fullname(i) = trim(line2(1:j-1)) + end if + end do + close(unit) + lgr => logging%get_logger('HISTORY.sampler') + call lgr%debug('%a %i8', 'nstation=', nstation) + call lgr%debug('%a %a %a', 'sampler%station_name(1:2) : ', & + trim(sampler%station_name(1)), trim(sampler%station_name(2))) + call lgr%debug('%a %f8.2 %f8.2', 'sampler%lons(1:2) : ',& + sampler%lons(1),sampler%lons(2)) + call lgr%debug('%a %f8.2 %f8.2', 'sampler%lats(1:2) : ',& + sampler%lats(1),sampler%lats(2)) + + !__ 2. create LocStreamFactory, then esmf_ls including route_handle + ! + sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) + sampler%esmf_ls = sampler%LSF%create_locstream(_RC) + ! + ! init ofile + sampler%ofile='' + sampler%obs_written=0 + + _RETURN(_SUCCESS) + end function new_StationSampler_readfile + + + subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_FieldBundle), intent(in) :: bundle + type(TimeData), intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + integer, optional, intent(out) :: rc + + type(variable) :: v + type(ESMF_Grid) :: grid + type(ESMF_Field) :: field + integer :: fieldCount + integer :: field_rank + integer :: nstation + logical :: is_present + integer :: ub(ESMF_MAXDIM) + integer :: lb(ESMF_MAXDIM) + logical :: do_vertical_regrid + integer :: status + integer :: i + + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims + + !__ 1. metadata add_dimension, + ! add_variable for time, latlon, station + ! + this%bundle = bundle + nstation = this%nstation + if (present(vdata)) then + this%vdata = vdata + else + this%vdata = VerticalData(_RC) + end if + call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! specify lev in fmd + do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) then + call this%vdata%get_interpolating_variable(this%bundle,_RC) + endif + + call timeInfo%add_time_to_metadata(this%fmd,_RC) ! specify time in fmd + this%time_info = timeInfo + + call this%fmd%add_dimension('station_index',nstation) + + v = Variable(type=pFIO_REAL32, dimensions='station_index') + call v%add_attribute('long_name','longitude') + call v%add_attribute('unit','degree_east') + call this%fmd%add_variable('longitude',v) + + v = Variable(type=pFIO_REAL32, dimensions='station_index') + call v%add_attribute('long_name','latitude') + call v%add_attribute('unit','degree_north') + call this%fmd%add_variable('latitude',v) + + v = Variable(type=pFIO_INT32, dimensions='station_index') + call this%fmd%add_variable('station_id',v) + v = Variable(type=pFIO_STRING, dimensions='station_index') + call v%add_attribute('long_name','station name') + call this%fmd%add_variable('station_name',v) + + + !__ 2. filemetadata: extract field from bundle, add_variable + ! + call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + var_name=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(bundle,var_name,field=field,_RC) + call ESMF_FieldGet(field,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) + else + long_name = var_name + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) + else + units = 'unknown' + endif + if (field_rank==2) then + vdims = "station_index,time" + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[nstation,1]) + else if (field_rank==3) then + vdims = "lev,station_index,time" + call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) + end if + call v%add_attribute('units', trim(units)) + call v%add_attribute('long_name', trim(long_name)) + call v%add_attribute('missing_value', MAPL_UNDEF) + call v%add_attribute('_FillValue', MAPL_UNDEF) + call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) + call this%fmd%add_variable(trim(var_name),v,_RC) + end do + deallocate (fieldNameList) + + + !__ 3. locstream route handle + ! + call ESMF_FieldBundleGet(bundle,grid=grid,_RC) + this%regridder = LocStreamRegridder(grid,this%esmf_ls,_RC) + + + _RETURN(_SUCCESS) + end subroutine add_metadata_route_handle + + + subroutine append_file(this,current_time,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + ! + integer :: status + integer :: fieldCount + integer :: ub(1), lb(1) + type(ESMF_Field) :: src_field,dst_field + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) + real(kind=REAL32), allocatable :: arr(:,:) + character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) + character(len=ESMF_MAXSTR) :: xname + real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: i, rank + integer :: nx, nz + + this%obs_written=this%obs_written+1 + + !__ 1. put_var: time variable + ! + rtimes = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%setup_eta_to_pressure(_RC) + end if + if (mapl_am_i_root()) then + call this%formatter%put_var('time',rtimes(1:1),& + start=[this%obs_written],count=[1],_RC) + end if + + !__ 2. put_var: ungridded_dim from src to dst [regrid] + ! + call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) + allocate (fieldNameList(fieldCount)) + call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) + do i=1, fieldCount + xname=trim(fieldNameList(i)) + call ESMF_FieldBundleGet(this%bundle,xname,field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname, & + typekind=ESMF_TYPEKIND_R4,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) + call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) + if (mapl_am_i_root()) then + call this%formatter%put_var(xname,p_dst_2d,& + start=[1,this%obs_written],count=[this%nstation,1],_RC) + end if + call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + else if (rank==3) then + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + if (this%vdata%lm/=(ub(1)-lb(1)+1)) then + lb(1)=1 + ub(1)=this%vdata%lm + end if + dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname,& + typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) + call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) + if (mapl_am_i_root()) then + nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx)) + arr=reshape(p_dst_3d,[nz,nx],order=[2,1]) + call this%formatter%put_var(xname,arr,& + start=[1,1,this%obs_written],count=[nz,nx,1],_RC) + !note: lev,station,time + deallocate(arr) + end if + call ESMF_FieldDestroy(dst_field,nogarbage=.true.) + else + _FAIL('grid2LS regridder: rank > 3 not implemented') + end if + end do + deallocate (fieldNameList) + _RETURN(_SUCCESS) + end subroutine append_file + + + subroutine create_file_handle(this,filename,rc) + class(StationSampler), intent(inout) :: this + character(len=*), intent(inout) :: filename ! for ouput nc + integer, optional, intent(out) :: rc + type(variable) :: v + integer :: status, j + + this%ofile = trim(filename) + v = this%time_info%define_time_variable(_RC) + call this%fmd%modify_variable('time',v,_RC) + this%obs_written = 0 + + if (.not. mapl_am_I_root()) then + _RETURN(_SUCCESS) + end if + call this%formatter%create(trim(filename),_RC) + call this%formatter%write(this%fmd,_RC) + call this%formatter%put_var('longitude',this%lons,_RC) + call this%formatter%put_var('latitude',this%lats,_RC) + call this%formatter%put_var('station_id',this%station_id,_RC) + call this%formatter%put_var('station_name',this%station_name,_RC) + + _RETURN(_SUCCESS) + end subroutine create_file_handle + + + subroutine close_file_handle(this,rc) + class(StationSampler), intent(inout) :: this + integer, optional, intent(out) :: rc + integer :: status + if (trim(this%ofile) /= '') then + if (mapl_am_i_root()) then + call this%formatter%close(_RC) + end if + end if + _RETURN(_SUCCESS) + end subroutine close_file_handle + + + function compute_time_for_current(this,current_time,rc) result(rtimes) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(in) :: current_time + integer, optional, intent(out) :: rc + real(ESMF_KIND_R8), allocatable :: rtimes(:) + integer :: status + type(ESMF_TimeInterval) :: tint + type(ESMF_Time) :: file_start_time + character(len=ESMF_MAXSTR) :: tunit + + allocate(rtimes(1),_STAT) + call this%get_file_start_time(file_start_time,tunit,_RC) + tint = current_time-file_start_time + select case(trim(tunit)) + case ('days') + call ESMF_TimeIntervalGet(tint,d_r8=rtimes(1),_RC) + case ('hours') + call ESMF_TimeIntervalGet(tint,h_r8=rtimes(1),_RC) + case ('minutes') + call ESMF_TimeIntervalGet(tint,m_r8=rtimes(1),_RC) + case default + _FAIL('illegal value for tunit: '//trim(tunit)) + end select + _RETURN(_SUCCESS) + end function compute_time_for_current + + + !-- a subroutine from MAPL_HistoryTrajectoryMod.F90 + ! TODO: consolidate with trajectory + subroutine get_file_start_time(this,start_time,time_units,rc) + class(StationSampler), intent(inout) :: this + type(ESMF_Time), intent(inout) :: start_time + character(len=*), intent(inout) :: time_units + integer, optional, intent(out) :: rc + + integer :: status + class(Variable), pointer :: var + type(Attribute), pointer :: attr + class(*), pointer :: pTimeUnits + character(len=ESMF_MAXSTR) :: timeUnits + + integer ypos(2), mpos(2), dpos(2), hpos(2), spos(2) + integer strlen + integer firstdash, lastdash + integer firstcolon, lastcolon + integer lastspace,since_pos + integer year,month,day,hour,min,sec + + var => this%fmd%get_variable('time',_RC) + attr => var%get_attribute('units') + ptimeUnits => attr%get_value() + select type(pTimeUnits) + type is (character(*)) + timeUnits = pTimeUnits + strlen = LEN_TRIM (TimeUnits) + + since_pos = index(TimeUnits, 'since') + time_units = trim(TimeUnits(:since_pos-1)) + time_units = trim(time_units) + + firstdash = index(TimeUnits, '-') + lastdash = index(TimeUnits, '-', BACK=.TRUE.) + + if (firstdash .LE. 0 .OR. lastdash .LE. 0) then + if (present(rc)) rc = -1 + return + endif + ypos(2) = firstdash - 1 + mpos(1) = firstdash + 1 + ypos(1) = ypos(2) - 3 + + mpos(2) = lastdash - 1 + dpos(1) = lastdash + 1 + dpos(2) = dpos(1) + 1 + + read ( TimeUnits(ypos(1):ypos(2)), * ) year + read ( TimeUnits(mpos(1):mpos(2)), * ) month + read ( TimeUnits(dpos(1):dpos(2)), * ) day + + firstcolon = index(TimeUnits, ':') + if (firstcolon .LE. 0) then + ! If no colons, check for hour. + ! Logic below assumes a null character or something else is after the hour + ! if we do not find a null character add one so that it correctly parses time + if (TimeUnits(strlen:strlen) /= C_NULL_CHAR) then + TimeUnits = trim(TimeUnits)//C_NULL_CHAR + strlen=len_trim(TimeUnits) + endif + lastspace = index(TRIM(TimeUnits), ' ', BACK=.TRUE.) + if ((strlen-lastspace).eq.2 .or. (strlen-lastspace).eq.3) then + hpos(1) = lastspace+1 + hpos(2) = strlen-1 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + min = 0 + sec = 0 + else + hour = 0 + min = 0 + sec = 0 + endif + else + hpos(1) = firstcolon - 2 + hpos(2) = firstcolon - 1 + lastcolon = index(TimeUnits, ':', BACK=.TRUE.) + if ( lastcolon .EQ. firstcolon ) then + mpos(1) = firstcolon + 1 + mpos(2) = firstcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + sec = 0 + else + mpos(1) = firstcolon + 1 + mpos(2) = lastcolon - 1 + spos(1) = lastcolon + 1 + spos(2) = lastcolon + 2 + read (TimeUnits(hpos(1):hpos(2)), * ) hour + read (TimeUnits(mpos(1):mpos(2)), * ) min + read (TimeUnits(spos(1):spos(2)), * ) sec + endif + endif + class default + _FAIL("Time unit must be character") + end select + call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,_RC) + _RETURN(_SUCCESS) + end subroutine get_file_start_time + + ! TODO: delete and use system utilities when available + Subroutine count_substring (str, t, ncount, rc) + character (len=*), intent(in) :: str + character (len=*), intent(in) :: t + integer, intent(out) :: ncount + integer, optional, intent(out) :: rc + integer :: i, k, lt + integer :: status + ncount=0 + k=1 + lt = len(t) - 1 + do + i=index(str(k:), t) + if (i==0) exit + ncount = ncount + 1 + k=k+i+lt + end do + _RETURN(_SUCCESS) + end subroutine count_substring + + + subroutine CSV_read_line_with_CH_I_R(line, name, lon, lat, rc) + character (len=*), intent(in) :: line + character (len=*), intent(out) :: name + real(kind=REAL64), intent(out) :: lon, lat + integer, optional, intent(out) :: rc + integer :: n + integer :: i, j, k + integer :: status + + i=index(line, ',') + j=index(line(i+1:), ',') + _ASSERT (i>0, 'not CSV format') + _ASSERT (j>0, 'CSV format: find only 1 comma, should be > 1') + j=i+j + + read(line(1:i-1), '(a100)') name + k=index(line(i+1:j-1), '.') + if (k > 0) then + read(line(i+1:j-1), *) lon + else + read(line(i+1:j-1), *) i + lon = i + endif + + k=index(line(j+1:), '.') + if (k > 0) then + read(line(j+1:), *) lat + else + read(line(j+1:), *) i + lat = i + endif + + !!write(6,*) trim(name), lon, lat + _RETURN(_SUCCESS) + + end subroutine CSV_read_line_with_CH_I_R + +end module StationSamplerMod diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 new file mode 100644 index 000000000000..ab646a3ea0d3 --- /dev/null +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -0,0 +1,162 @@ +module HistoryTrajectoryMod + use ESMF + use MAPL_FileMetadataUtilsMod + use MAPL_GriddedIOItemVectorMod + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use LocStreamFactoryMod + use MAPL_LocstreamRegridderMod + use MAPL_ObsUtilMod + use, intrinsic :: iso_fortran_env, only: REAL64 + implicit none + + private + + public :: HistoryTrajectory + type :: HistoryTrajectory + private + type(ESMF_LocStream) :: LS_rt + type(ESMF_LocStream) :: LS_ds + type(LocStreamFactory) :: locstream_factory + type(obs_unit), allocatable :: obs(:) + type(ESMF_Time), allocatable :: times(:) + real(kind=REAL64), allocatable :: lons(:) + real(kind=REAL64), allocatable :: lats(:) + real(kind=REAL64), allocatable :: times_R8(:) + integer, allocatable :: obstype_id(:) + integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file + + type(ESMF_FieldBundle) :: bundle + type(ESMF_FieldBundle) :: output_bundle + type(ESMF_FieldBundle) :: acc_bundle + type(ESMF_Field) :: fieldA + type(ESMF_Field) :: fieldB + + type(GriddedIOitemVector) :: items + type(VerticalData) :: vdata + logical :: do_vertical_regrid + + type(LocstreamRegridder) :: regridder + type(TimeData) :: time_info + type(ESMF_Clock) :: clock + type(ESMF_Alarm), public :: alarm + type(ESMF_Time) :: RingTime + type(ESMF_TimeInterval), public :: epoch_frequency + + integer :: nobs_type +! character(len=ESMF_MAXSTR) :: nc_index +! character(len=ESMF_MAXSTR) :: nc_time +! character(len=ESMF_MAXSTR) :: nc_latitude +! character(len=ESMF_MAXSTR) :: nc_longitude + + character(len=ESMF_MAXSTR) :: index_name_x + character(len=ESMF_MAXSTR) :: var_name_time + character(len=ESMF_MAXSTR) :: var_name_lat + character(len=ESMF_MAXSTR) :: var_name_lon + character(len=ESMF_MAXSTR) :: var_name_time_full + character(len=ESMF_MAXSTR) :: var_name_lat_full + character(len=ESMF_MAXSTR) :: var_name_lon_full + character(len=ESMF_MAXSTR) :: datetime_units + character(len=ESMF_MAXSTR) :: Location_index_name + integer :: epoch ! unit: second + integer(kind=ESMF_KIND_I8) :: epoch_index(2) + real(kind=ESMF_KIND_R8), pointer:: obsTime(:) + integer :: nobs_epoch + integer :: nobs_epoch_sum + type(ESMF_Time) :: obsfile_start_time ! user specify + type(ESMF_Time) :: obsfile_end_time + type(ESMF_TimeInterval) :: obsfile_interval + integer :: obsfile_Ts_index ! for epoch + integer :: obsfile_Te_index + logical :: active + contains + procedure :: initialize => initialize_ + procedure :: create_variable => create_metadata_variable + procedure :: create_file_handle + procedure :: close_file_handle + procedure :: append_file + procedure :: create_new_bundle + procedure :: create_grid + procedure :: regrid_accumulate => regrid_accumulate_on_xsubset + procedure :: destroy_rh_regen_LS + procedure :: get_x_subset + end type HistoryTrajectory + + interface HistoryTrajectory + module procedure HistoryTrajectory_from_config + end interface HistoryTrajectory + + + interface + module function HistoryTrajectory_from_config(config,string,clock,rc) result(traj) + type(HistoryTrajectory) :: traj + type(ESMF_Config), intent(inout) :: config + character(len=*), intent(in) :: string + type(ESMF_Clock), intent(in) :: clock + integer, optional, intent(out) :: rc + end function HistoryTrajectory_from_config + + module subroutine initialize_(this,items,bundle,timeInfo,vdata,reinitialize,rc) + class(HistoryTrajectory), intent(inout) :: this + type(GriddedIOitemVector), optional, intent(inout) :: items + type(ESMF_FieldBundle), optional, intent(inout) :: bundle + type(TimeData), optional, intent(inout) :: timeInfo + type(VerticalData), optional, intent(inout) :: vdata + logical, optional, intent(in) :: reinitialize + integer, optional, intent(out) :: rc + end subroutine initialize_ + + module subroutine create_metadata_variable(this,vname,rc) + class(HistoryTrajectory), intent(inout) :: this + character(len=*), intent(in) :: vname + integer, optional, intent(out) :: rc + end subroutine create_metadata_variable + + module function create_new_bundle(this,rc) result(new_bundle) + class(HistoryTrajectory), intent(inout) :: this + type(ESMF_FieldBundle) :: new_bundle + integer, optional, intent(out) :: rc + end function create_new_bundle + + module subroutine create_file_handle(this,filename_suffix,rc) + class(HistoryTrajectory), intent(inout) :: this + character(len=*), intent(in) :: filename_suffix + integer, optional, intent(out) :: rc + end subroutine create_file_handle + + module subroutine close_file_handle(this,rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine close_file_handle + + module subroutine append_file(this,current_time,rc) + class(HistoryTrajectory), intent(inout) :: this + type(ESMF_Time), intent(inout) :: current_time + integer, optional, intent(out) :: rc + end subroutine append_file + + module subroutine create_grid(this, rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine create_grid + + module subroutine regrid_accumulate_on_xsubset (this, rc) + implicit none + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine regrid_accumulate_on_xsubset + + module subroutine get_x_subset(this, interval, x_subset, rc) + class(HistoryTrajectory), intent(inout) :: this + type(ESMF_Time), intent(in) :: interval(2) + integer, intent(out) :: x_subset(2) + integer, optional, intent(out) :: rc + end subroutine get_x_subset + + module subroutine destroy_rh_regen_LS (this, rc) + class(HistoryTrajectory), intent(inout) :: this + integer, optional, intent(out) :: rc + end subroutine destroy_rh_regen_LS + + end interface +end module HistoryTrajectoryMod diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 new file mode 100644 index 000000000000..165c40a42331 --- /dev/null +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -0,0 +1,1275 @@ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +submodule (HistoryTrajectoryMod) HistoryTrajectory_implement + use ESMF + use MAPL_ErrorHandlingMod + use MAPL_KeywordEnforcerMod + use LocStreamFactoryMod + use MAPL_LocstreamRegridderMod + use MAPL_FileMetadataUtilsMod + use pFIO + use MAPL_GriddedIOItemMod + use MAPL_GriddedIOItemVectorMod + use MAPL_TimeDataMod + use MAPL_VerticalDataMod + use MAPL_BaseMod + use MAPL_CommsMod + use MAPL_SortMod + use MAPL_NetCDF + use MAPL_StringTemplate + use Plain_netCDF_Time + use MAPL_ObsUtilMod + use, intrinsic :: iso_fortran_env, only: REAL32 + use, intrinsic :: iso_fortran_env, only: REAL64 + implicit none + + contains + + module procedure HistoryTrajectory_from_config + use BinIOMod + use pflogger, only : Logger, logging + type(ESMF_Time) :: currTime + type(ESMF_TimeInterval) :: epoch_frequency + type(ESMF_TimeInterval) :: obs_time_span + integer :: time_integer, second + integer :: status + character(len=ESMF_MAXSTR) :: STR1, line + character(len=ESMF_MAXSTR) :: symd, shms + integer :: nline, col + integer, allocatable :: ncol(:) + character(len=ESMF_MAXSTR), allocatable :: word(:) + integer :: nobs, head, jvar + logical :: tend + integer :: i, j, k, M + integer :: count + integer :: unitr, unitw + type(Logger), pointer :: lgr + + traj%clock=clock + call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) + call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(string)//'Epoch:', default=0, _RC) + _ASSERT(time_integer /= 0, 'Epoch value in config wrong') + second = hms_2_s(time_integer) + call ESMF_TimeIntervalSet(epoch_frequency, s=second, _RC) + traj%Epoch = time_integer + traj%RingTime = currTime + traj%epoch_frequency = epoch_frequency + traj%alarm = ESMF_AlarmCreate( clock=clock, RingInterval=epoch_frequency, & + RingTime=traj%RingTime, sticky=.false., _RC ) + + call ESMF_ConfigGetAttribute(config, value=traj%index_name_x, default="", & + label=trim(string) // 'index_name_x:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_lon_full, default="", & + label=trim(string) // 'var_name_lon:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_lat_full, default="", & + label=trim(string) // 'var_name_lat:', _RC) + call ESMF_ConfigGetAttribute(config, value=traj%var_name_time_full, default="", & + label=trim(string) // 'var_name_time:', _RC) + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_begin:', _RC) + if (trim(STR1)=='') then + traj%obsfile_start_time = currTime + call ESMF_TimeGet(currTime, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) + endif + else + call ESMF_TimeSet(traj%obsfile_start_time, STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_begin provided: ', trim(STR1) + end if + end if + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_end:', _RC) + if (trim(STR1)=='') then + call ESMF_TimeIntervalSet(obs_time_span, d=14, _RC) + traj%obsfile_end_time = traj%obsfile_start_time + obs_time_span + call ESMF_TimeGet(traj%obsfile_end_time, timestring=STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end missing, default = begin+14D:', trim(STR1) + endif + else + call ESMF_TimeSet(traj%obsfile_end_time, STR1, _RC) + if (mapl_am_I_root()) then + write(6,105) 'obs_file_end provided:', trim(STR1) + end if + end if + + call ESMF_ConfigGetAttribute(config, value=STR1, default="", & + label=trim(string) // 'obs_file_interval:', _RC) + _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') + if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) + if (mapl_am_I_root()) write(6,106) 'Epoch (second) :', second + + i= index( trim(STR1), ' ' ) + if (i>0) then + symd=STR1(1:i-1) + shms=STR1(i+1:) + else + symd='' + shms=trim(STR1) + endif + call convert_twostring_2_esmfinterval (symd, shms, traj%obsfile_interval, _RC) + traj%active = .true. + + + ! __ s1. overall print + call ESMF_ConfigGetDim(config, nline, col, label=trim(string)//'obs_files:', rc=rc) + _ASSERT(rc==0 .AND. nline > 0, 'obs_files not found') + !! write(6,*) 'nline, col', nline, col + allocate(ncol(1:nline)) + + call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC ) + do i = 1, nline + call ESMF_ConfigNextLine(config, _RC) + ncol(i) = ESMF_ConfigGetLen(config, _RC) + !!write(6,*) 'line', i, 'ncol(i)', ncol(i) + enddo + + + + ! __ s2. find nobs && distinguish design with vs wo '------' + nobs=0 + call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) + do i=1, nline + call ESMF_ConfigNextLine( config, tableEnd=tend, _RC) + call ESMF_ConfigGetAttribute( config, STR1, _RC) + if ( index(trim(STR1), '-----') > 0 ) nobs=nobs+1 + enddo + + ! __ s3. retrieve template and geoval, set metadata file_handle + lgr => logging%get_logger('HISTORY.sampler') + if ( nobs == 0 ) then + ! + ! treatment-1: + ! + _FAIL('this setting in HISTORY.rc obs_files: is not supported, stop') + traj%nobs_type = nline ! here .rc format cannot have empty spaces + allocate (traj%obs(nline)) + call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) + do i=1, nline + call ESMF_ConfigNextLine( config, tableEnd=tend, _RC) + call ESMF_ConfigGetAttribute( config, traj%obs(i)%input_template, _RC) + traj%obs(i)%export_all_geoval = .true. + enddo + else + ! + !-- selectively output geovals + ! treatment-2: + ! + traj%nobs_type = nobs + allocate (traj%obs(nobs)) + ! + nobs=0 ! reuse counter + head=1 + jvar=0 + + ! + ! count '------' in history.rc as special markers for ngeoval + ! + call ESMF_ConfigFindLabel(config, trim(string)//'obs_files:', _RC) + do i=1, nline + call ESMF_ConfigNextLine(config, tableEnd=tend, _RC) + M = ncol(i) + _ASSERT(M>=1, '# of columns should be >= 1') + allocate (word(M)) + count=0 + do col=1, M + call ESMF_ConfigGetAttribute(config, word(col), _RC) + if (trim(word(col))/=',') then + count=count+1 + end if + enddo + if (count ==1 .or. count==2) then + ! 1-item case: file template or one-var + ! 2-item : var1 , 'root' case + STR1=trim(word(1)) + else + ! 3-item : var1 , 'root', var1_alias case + STR1=trim(word(M)) + end if + deallocate(word) + if ( index(trim(STR1), '-----') == 0 ) then + if (head==1 .AND. trim(STR1)/='') then + nobs=nobs+1 + traj%obs(nobs)%input_template = trim(STR1) + traj%obs(nobs)%export_all_geoval = .false. + head=0 + else + if (trim(STR1)/='') then + jvar=jvar+1 + traj%obs(nobs)%geoval_name(jvar) = trim(STR1) + end if + end if + else + traj%obs(nobs)%ngeoval=jvar + head=1 + jvar=0 + endif + enddo + end if + + do k=1, traj%nobs_type + allocate (traj%obs(k)%metadata) + if (mapl_am_i_root()) then + allocate (traj%obs(k)%file_handle) + end if + end do + + call lgr%debug('%a %i8', 'nobs_type=', traj%nobs_type) + do i=1, traj%nobs_type + call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & + trim(traj%obs(i)%input_template)) + j=index(traj%obs(i)%input_template , '%') + k=index(traj%obs(i)%input_template , '/', back=.true.) + _ASSERT(j>0, '% is not found, template is wrong') + traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) + end do + + _RETURN(_SUCCESS) + + +105 format (1x,a,2x,a) +106 format (1x,a,2x,i8) + end procedure HistoryTrajectory_from_config + + + ! + !-- integrate both initialize and reinitialize + ! + module procedure initialize_ + integer :: status + type(ESMF_Grid) :: grid + type(variable) :: v + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_Time) :: currTime + integer :: k + + if (.not. present(reinitialize)) then + if(present(bundle)) this%bundle=bundle + if(present(items)) this%items=items + if(present(timeInfo)) this%time_info=timeInfo + if (present(vdata)) then + this%vdata=vdata + else + this%vdata=VerticalData(_RC) + end if + else + if (reinitialize) then + do k=1, this%nobs_type + allocate (this%obs(k)%metadata) + if (mapl_am_i_root()) then + allocate (this%obs(k)%file_handle) + end if + end do + end if + end if + + do k=1, this%nobs_type + call this%vdata%append_vertical_metadata(this%obs(k)%metadata,this%bundle,_RC) + end do + this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) + if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) + + call ESMF_ClockGet (this%clock, CurrTime=currTime, _RC) + call get_obsfile_Tbracket_from_epoch(currTime, & + this%obsfile_start_time, this%obsfile_end_time, & + this%obsfile_interval, this%epoch_frequency, & + this%obsfile_Ts_index, this%obsfile_Te_index, _RC) + if (this%obsfile_Te_index < 0) then + if (mapl_am_I_root()) then + write(6,*) "model start time is earlier than obsfile_start_time" + write(6,*) "solution: adjust obsfile_start_time and Epoch in rc file" + end if + _FAIL("obs file not found at init time") + endif + call this%create_grid(_RC) + + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%regridder = LocStreamRegridder(grid,this%LS_ds,_RC) + this%output_bundle = this%create_new_bundle(_RC) + this%acc_bundle = this%create_new_bundle(_RC) + + + do k=1, this%nobs_type + call this%obs(k)%metadata%add_dimension(this%index_name_x, this%obs(k)%nobs_epoch) + if (this%time_info%integer_time) then + v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) + else + v = Variable(type=PFIO_REAL64,dimensions=this%index_name_x) + end if + call v%add_attribute('units', this%datetime_units) + call v%add_attribute('long_name', 'dateTime') + call this%obs(k)%metadata%add_variable(this%var_name_time,v) + + v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) + call v%add_attribute('units', '1') + call v%add_attribute('long_name', 'Location index in corresponding IODA file') + call this%obs(k)%metadata%add_variable(this%location_index_name,v) + + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) + call v%add_attribute('units','degrees_east') + call v%add_attribute('long_name','longitude') + call this%obs(k)%metadata%add_variable(this%var_name_lon,v) + + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) + call v%add_attribute('units','degrees_north') + call v%add_attribute('long_name','latitude') + call this%obs(k)%metadata%add_variable(this%var_name_lat,v) + end do + + ! push varible names down to each obs(k); see create_metadata_variable + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call this%create_variable(item%xname,_RC) + else if (item%itemType == ItemTypeVector) then + call this%create_variable(item%xname,_RC) + call this%create_variable(item%yname,_RC) + end if + call iter%next() + enddo + + _RETURN(_SUCCESS) + + end procedure initialize_ + + + + module procedure create_metadata_variable + type(ESMF_Field) :: field + type(variable) :: v + logical :: is_present + integer :: field_rank, status + character(len=ESMF_MAXSTR) :: var_name,long_name,units,vdims + integer :: k, ig + + call ESMF_FieldBundleGet(this%bundle,vname,field=field,_RC) + call ESMF_FieldGet(field,name=var_name,rank=field_rank,_RC) + call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, _RC) + else + long_name = var_name + endif + call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) + if ( is_present ) then + call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, _RC) + else + units = 'unknown' + endif + if (field_rank==2) then + vdims = this%index_name_x + else if (field_rank==3) then + vdims = trim(this%index_name_x)//",lev" + end if + v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) + call v%add_attribute('units',trim(units)) + call v%add_attribute('long_name',trim(long_name)) + call v%add_attribute('missing_value',MAPL_UNDEF) + call v%add_attribute('_FillValue',MAPL_UNDEF) + call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) + + do k = 1, this%nobs_type + do ig = 1, this%obs(k)%ngeoval + if (trim(var_name) == trim(this%obs(k)%geoval_name(ig))) then + call this%obs(k)%metadata%add_variable(trim(var_name),v,_RC) + endif + enddo + enddo + + _RETURN(_SUCCESS) + end procedure create_metadata_variable + + + module procedure create_new_bundle + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_Field) :: src_field,dst_field + integer :: rank,lb(1),ub(1) + integer :: status + + new_bundle = ESMF_FieldBundleCreate(_RC) + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + dst_field = ESMF_FieldCreate(this%LS_ds,name=trim(item%xname), & + typekind=ESMF_TYPEKIND_R4,_RC) + else if (rank==3) then + call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + if (this%vdata%lm/=(ub(1)-lb(1)+1)) then + lb(1)=1 + ub(1)=this%vdata%lm + end if + dst_field = ESMF_FieldCreate(this%LS_ds,name=trim(item%xname), & + typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) + end if + call MAPL_FieldBundleAdd(new_bundle,dst_field,_RC) + else if (item%itemType == ItemTypeVector) then +!! _FAIL("ItemTypeVector not yet supported") + end if + call iter%next() + enddo + _RETURN(_SUCCESS) + + end procedure create_new_bundle + + + module procedure create_file_handle + use pflogger, only : Logger, logging + integer :: status + integer :: k + character(len=ESMF_MAXSTR) :: filename + type(Logger), pointer :: lgr + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + lgr => logging%get_logger('HISTORY.sampler') + do k=1, this%nobs_type + call this%obs(k)%metadata%modify_dimension(this%index_name_x, this%obs(k)%nobs_epoch) + enddo + if (mapl_am_I_root()) then + do k=1, this%nobs_type + if (this%obs(k)%nobs_epoch > 0) then + filename=trim(this%obs(k)%name)//trim(filename_suffix) + call lgr%debug('%a %a', & + "Sampling to new file : ",trim(filename)) + call this%obs(k)%file_handle%create(trim(filename),_RC) + call this%obs(k)%file_handle%write(this%obs(k)%metadata,_RC) + end if + enddo + end if + + _RETURN(_SUCCESS) + end procedure create_file_handle + + + module procedure close_file_handle + integer :: status + integer :: k + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + if (mapl_am_I_root()) then + do k=1, this%nobs_type + if (this%obs(k)%nobs_epoch > 0) then + call this%obs(k)%file_handle%close(_RC) + end if + end do + end if + _RETURN(_SUCCESS) + end procedure close_file_handle + + + module procedure create_grid + use pflogger, only: Logger, logging + character(len=ESMF_MAXSTR) :: filename + integer(ESMF_KIND_I4) :: num_times + integer :: len + integer :: len_full + integer :: status + type(Logger), pointer :: lgr + + character(len=ESMF_MAXSTR) :: grp_name + character(len=ESMF_MAXSTR) :: timeunits_file + character :: new_char(ESMF_MAXSTR) + + real(kind=REAL64), allocatable :: lons_full(:), lats_full(:) + real(kind=REAL64), allocatable :: times_R8_full(:) + real(kind=REAL64) :: t_shift + integer, allocatable :: obstype_id_full(:) + integer, allocatable :: location_index_ioda_full(:) + integer, allocatable :: IA_full(:) + + real(ESMF_KIND_R8), pointer :: ptAT(:) + type(ESMF_routehandle) :: RH + type(ESMF_Time) :: timeset(2) + type(ESMF_Time) :: current_time + type(ESMF_Time) :: time0 + type(ESMF_TimeInterval) :: dt + type(ESMF_Grid) :: grid + + type(ESMF_VM) :: vm + integer :: mypet, petcount + + integer :: i, j, k, L, ii, jj + integer :: fid_s, fid_e + integer(kind=ESMF_KIND_I8) :: j0, j1 + integer(kind=ESMF_KIND_I8) :: jt1, jt2 + integer(kind=ESMF_KIND_I8) :: nstart, nend + real(kind=ESMF_KIND_R8) :: jx0, jx1 + integer :: nx, nx_sum + integer :: n0 + integer :: arr(1) + integer :: sec + integer, allocatable :: ix(:) ! counter for each obs(k)%nobs_epoch + integer :: nx2 + logical :: EX ! file + logical :: zero_obs + +!! this%datetime_units = "seconds since 1970-01-01 00:00:00" + lgr => logging%get_logger('HISTORY.sampler') + + call ESMF_VMGetGlobal(vm,_RC) + call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) + + if (this%index_name_x == '') then + ! + !-- non IODA case / non netCDF + ! + _FAIL('non-IODA format is not implemented here') + end if + + ! + !-- IODA case + ! + i=index(this%var_name_lon_full, '/') + if (i==0) then + grp_name = '' + call lgr%debug('%a', 'grp_name not found') + else + grp_name = this%var_name_lon_full(1:i-1) + end if + this%var_name_lon = this%var_name_lon_full(i+1:) + i=index(this%var_name_lat_full, '/') + this%var_name_lat = this%var_name_lat_full(i+1:) + i=index(this%var_name_time_full, '/') + this%var_name_time= this%var_name_time_full(i+1:) + this%location_index_name = 'location_index_in_iodafile' + + call lgr%debug('%a', 'grp_name,this%index_name_x,this%var_name_lon,this%var_name_lat,this%var_name_time') + call lgr%debug('%a %a %a %a %a', & + trim(grp_name),trim(this%index_name_x),trim(this%var_name_lon),& + trim(this%var_name_lat),trim(this%var_name_time)) + + L=0 + fid_s=this%obsfile_Ts_index + fid_e=this%obsfile_Te_index + + call lgr%debug('%a %i10 %i10', & + 'fid_s, fid_e', fid_s, fid_e) + + arr(1)=0 ! len_full + if (mapl_am_I_root()) then + len = 0 + do k=1, this%nobs_type + j = max (fid_s, L) + do while (j<=fid_e) + filename = get_filename_from_template_use_index( & + this%obsfile_start_time, this%obsfile_interval, & + j, this%obs(k)%input_template, EX, _RC) + if (EX) then + call lgr%debug('%a %i10', 'exist: filename fid j :', j) + call lgr%debug('%a %a', 'exist: true filename :', trim(filename)) + call get_ncfile_dimension(filename, tdim=num_times, key_time=this%index_name_x, _RC) + len = len + num_times + else + call lgr%debug('%a %i10', 'non-exist: filename fid j :', j) + call lgr%debug('%a %a', 'non-exist: missing filename:', trim(filename)) + end if + j=j+1 + enddo + enddo + arr(1)=len + + if (len>0) then + allocate(lons_full(len),lats_full(len),_STAT) + allocate(times_R8_full(len),_STAT) + allocate(obstype_id_full(len),_STAT) + allocate(location_index_ioda_full(len),_STAT) + allocate(IA_full(len),_STAT) + call lgr%debug('%a %i12', 'nobs from input file:', len) + len = 0 + ii = 0 + do k=1, this%nobs_type + j = max (fid_s, L) + do while (j<=fid_e) + filename = get_filename_from_template_use_index( & + this%obsfile_start_time, this%obsfile_interval, & + j, this%obs(k)%input_template, EX, _RC) + if (EX) then + ii = ii + 1 + call get_ncfile_dimension(trim(filename), tdim=num_times, key_time=this%index_name_x, _RC) + call get_v1d_netcdf_R8 (filename, this%var_name_lon, lons_full(len+1:), num_times, group_name=grp_name) + call get_v1d_netcdf_R8 (filename, this%var_name_lat, lats_full(len+1:), num_times, group_name=grp_name) + call get_v1d_netcdf_R8 (filename, this%var_name_time, times_R8_full(len+1:), num_times, group_name=grp_name) + call get_attribute_from_group (filename, grp_name, this%var_name_time, "units", timeunits_file) + if (ii == 1) then + this%datetime_units = trim(timeunits_file) + call lgr%debug('%a %a', 'datetime_units from 1st file:', trim(timeunits_file)) + end if + call diff_two_timeunits (this%datetime_units, timeunits_file, t_shift, _RC) + times_R8_full(len+1:len+num_times) = times_R8_full(len+1:len+num_times) + t_shift + obstype_id_full(len+1:len+num_times) = k + do jj = 1, num_times + location_index_ioda_full(len+jj) = jj + end do + len = len + num_times + end if + j=j+1 + enddo + enddo + end if + end if + + + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + if (nx_sum == 0) then + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) + this%epoch_index(1:2) = 0 + this%nobs_epoch = 0 + this%nobs_epoch_sum = 0 + ! + ! empty shell to keep regridding and destroy_RH_LS to work + ! + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) + this%LS_rt = this%locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) + call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) + this%obsTime= -1.d0 + rc = 0 + return + end if + call MAPL_CommsBcast(vm, this%datetime_units, N=ESMF_MAXSTR, ROOT=MAPL_Root, _RC) + + + + if (mapl_am_I_root()) then + call sort_index (times_R8_full, IA_full, _RC) + call apply_order_index (location_index_ioda_full, IA_full, _RC) + ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time + call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) + call ESMF_ClockGet(this%clock,currTime=current_time,_RC) + timeset(1) = current_time + timeset(2) = current_time + this%epoch_frequency + call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) + sec = hms_2_s(this%Epoch) + j1 = j0 + int(sec, kind=ESMF_KIND_I8) + jx0 = real ( j0, kind=ESMF_KIND_R8) + jx1 = real ( j1, kind=ESMF_KIND_R8) + + nstart=1; nend=size(times_R8_full) + call bisect( times_R8_full, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call bisect( times_R8_full, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) + call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) + call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) + call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & + times_R8_full(1), times_R8_full(nend)) + call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) + + +! if (jt1==jt2) then +! _FAIL('Epoch Time is too small, empty grid is generated, increase Epoch') +! endif + + !-- shift the zero item to index 1 + zero_obs = .false. + if (jt1/=jt2) then + zero_obs = .false. + if (jt1==0) jt1=1 + else + ! at most one obs point exist, set it .true. + zero_obs = .true. + !! if (jt1==0) jt1=1 + end if + + ! + !-- exclude the out-of-range case + ! + if ( zero_obs ) then + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) + this%epoch_index(1:2)=0 + this%nobs_epoch = 0 + nx=0 + arr(1)=nx + else + !! doulbe check + ! (x1, x2] design in bisect + this%epoch_index(1)= jt1 + 1 + +!! ! (x1, x2] design in bisect +!! if (jt1==0) then +!! this%epoch_index(1)= 1 +!! else +!! this%epoch_index(1)= jt1 +!! endif + _ASSERT(jt2<=len, 'bisect index for this%epoch_index(2) failed') + if (jt2==0) then + this%epoch_index(2)= 1 + else + this%epoch_index(2)= jt2 + endif + + nx= this%epoch_index(2) - this%epoch_index(1) + 1 + this%nobs_epoch = nx + + + allocate(this%lons(nx),this%lats(nx),_STAT) + allocate(this%times_R8(nx),_STAT) + allocate(this%obstype_id(nx),_STAT) + allocate(this%location_index_ioda(nx),_STAT) + + j=this%epoch_index(1) + do i=1, nx + this%lons(i) = lons_full(j) + this%lats(i) = lats_full(j) + this%times_R8(i) = times_R8_full(j) + this%obstype_id(i) = obstype_id_full(j) + this%location_index_ioda(i) = location_index_ioda_full(j) + j=j+1 + enddo + arr(1)=nx + + do k=1, this%nobs_type + this%obs(k)%nobs_epoch = 0 + enddo + do j = this%epoch_index(1), this%epoch_index(2) + k = obstype_id_full(j) + this%obs(k)%nobs_epoch = this%obs(k)%nobs_epoch + 1 + enddo + + do k=1, this%nobs_type + nx2 = this%obs(k)%nobs_epoch + allocate (this%obs(k)%lons(nx2)) + allocate (this%obs(k)%lats(nx2)) + allocate (this%obs(k)%times_R8(nx2)) + allocate (this%obs(k)%location_index_ioda(nx2)) + enddo + + allocate(ix(this%nobs_type)) + ix(:)=0 + j=this%epoch_index(1) + do i=1, nx + k = obstype_id_full(j) + ix(k) = ix(k) + 1 + this%obs(k)%lons(ix(k)) = lons_full(j) + this%obs(k)%lats(ix(k)) = lats_full(j) + this%obs(k)%times_R8(ix(k)) = times_R8_full(j) + this%obs(k)%location_index_ioda(ix(k)) = location_index_ioda_full(j) + !if (mod(k,10**8)==1) then + ! write(6,*) 'this%obs(k)%times_R8(ix(k))', this%obs(k)%times_R8(ix(k)) + !endif + j=j+1 + enddo + deallocate(ix) + deallocate(lons_full, lats_full, times_R8_full, obstype_id_full, location_index_ioda_full) + + call lgr%debug('%a %i12 %i12 %i12', & + 'epoch_index(1:2), nx', this%epoch_index(1), & + this%epoch_index(2), this%nobs_epoch) + do k=1, this%nobs_type + call lgr%debug('%a %i4 %a %i12', & + 'obs(', k, ')%nobs_epoch', this%obs(k)%nobs_epoch ) + enddo + end if + else + allocate(this%lons(0),this%lats(0),_STAT) + allocate(this%times_R8(0),_STAT) + allocate(this%obstype_id(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) + this%epoch_index(1:2)=0 + this%nobs_epoch = 0 + nx=0 + arr(1)=nx + endif + + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + this%nobs_epoch_sum = nx_sum + call lgr%debug('%a %i20', 'nobservation points=', nx_sum) + + + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) + this%LS_rt = this%locstream_factory%create_locstream(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + + this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) + this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) + + call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) + call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) + if (mypet == 0) then + ptAT(:) = this%times_R8(:) + end if + this%obsTime= -1.d0 + + call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) + call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) + + !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) + + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) + ! defer destroy fieldB at regen_grid step + ! + + + _RETURN(_SUCCESS) + end procedure create_grid + + + + module procedure append_file + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_RouteHandle) :: RH + + type(ESMF_Field) :: src_field, dst_field + type(ESMF_Field) :: acc_field + type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt + real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) + real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) + real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) + + integer :: is, ie, nx + integer :: lm + integer :: rank + integer :: status + integer :: j, k, ig + integer, allocatable :: ix(:) + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + is=1 + do k = 1, this%nobs_type + !-- limit nx < 2**32 (integer*4) + nx=this%obs(k)%nobs_epoch + if (nx >0) then + if (mapl_am_i_root()) then + call this%obs(k)%file_handle%put_var(this%var_name_time, real(this%obs(k)%times_R8), & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%var_name_lon, this%obs(k)%lons, & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & + start=[is], count=[nx], _RC) + end if + end if + enddo + + ! get RH from 2d field + src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + dst_field = ESMF_FieldCreate(this%LS_rt,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + call ESMF_FieldRedistStore(src_field,dst_field,RH,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) + + ! redist and put_var + lm = this%vdata%lm + acc_field_2d_rt = ESMF_FieldCreate (this%LS_rt, name='field_2d_rt', typekind=ESMF_TYPEKIND_R4, _RC) + acc_field_3d_rt = ESMF_FieldCreate (this%LS_rt, name='field_3d_rt', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + !!write(6, '(2x,a,2x,a)') 'item%xname', trim(item%xname) + + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) + call ESMF_FieldGet(acc_field,rank=rank,_RC) + if (rank==1) then + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC) + call ESMF_FieldGet( acc_field_2d_rt, localDE=0, farrayPtr=p_acc_rt_2d, _RC) + call ESMF_FieldRedist( acc_field, acc_field_2d_rt, RH, _RC) + if (mapl_am_i_root()) then + ! + !-- pack fields to obs(k)%p2d and put_var + ! + is=1 + ie=this%epoch_index(2)-this%epoch_index(1)+1 + do k=1, this%nobs_type + nx = this%obs(k)%nobs_epoch + allocate (this%obs(k)%p2d(nx)) + enddo + + allocate(ix(this%nobs_type)) + ix(:)=0 + do j=is, ie + k = this%obstype_id(j) + ix(k) = ix(k) + 1 + this%obs(k)%p2d(ix(k)) = p_acc_rt_2d(j) + enddo + + do k=1, this%nobs_type + if (ix(k) /= this%obs(k)%nobs_epoch) then + print*, 'obs_', k, ' : ix(k) /= this%obs(k)%nobs_epoch' + print*, 'obs_', k, ' : this%obs(k)%nobs_epoch, ix(k) =', this%obs(k)%nobs_epoch, ix(k) + _FAIL('test ix(k) failed') + endif + enddo + deallocate(ix) + do k=1, this%nobs_type + is = 1 + nx = this%obs(k)%nobs_epoch + if (nx>0) then + do ig = 1, this%obs(k)%ngeoval + if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then + call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & + start=[is],count=[nx]) + end if + enddo + endif + enddo + do k=1, this%nobs_type + deallocate (this%obs(k)%p2d) + enddo + end if + else if (rank==2) then + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) + call ESMF_FieldGet( acc_field_3d_rt, localDE=0, farrayPtr=p_acc_rt_3d, _RC) + + dst_field=ESMF_FieldCreate(this%LS_rt,typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) + call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) + + p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) + call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) + p_acc_rt_3d=reshape(p_dst, shape(p_acc_rt_3d), order=[2,1]) + + call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + + if (mapl_am_i_root()) then + ! + !-- pack fields to obs(k)%p3d and put_var + ! + is=1 + ie=this%epoch_index(2)-this%epoch_index(1)+1 + do k=1, this%nobs_type + nx = this%obs(k)%nobs_epoch + allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2))) + enddo + allocate(ix(this%nobs_type)) + ix(:)=0 + do j=is, ie + k = this%obstype_id(j) + ix(k) = ix(k) + 1 + this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) + enddo + deallocate(ix) + do k=1, this%nobs_type + is = 1 + nx = this%obs(k)%nobs_epoch + if (nx>0) then + do ig = 1, this%obs(k)%ngeoval + if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then + call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & + start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + end if + end do + endif + enddo + !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) + !!write(6,*) 'here in append_file: put_var 3d' + !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& + !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + !! + do k=1, this%nobs_type + deallocate (this%obs(k)%p3d) + enddo + end if + endif + else if (item%itemType == ItemTypeVector) then + _FAIL("ItemTypeVector not yet supported") + end if + call iter%next() + enddo + call ESMF_FieldDestroy(acc_field_2d_rt, noGarbage=.true., _RC) + call ESMF_FieldDestroy(acc_field_3d_rt, noGarbage=.true., _RC) + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + + _RETURN(_SUCCESS) + end procedure append_file + + + + + module procedure regrid_accumulate_on_xsubset + integer :: x_subset(2) + type(ESMF_Time) :: timeset(2) + type(ESMF_Time) :: current_time + type(ESMF_TimeInterval) :: dur + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_Field) :: src_field,dst_field,acc_field + integer :: rank + real(kind=REAL32), allocatable :: p_new_lev(:,:,:) + real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) + real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) + type(ESMF_VM) :: vm + integer :: mypet, petcount + integer :: is, ie, nx_sum + integer :: status + integer :: arr(1) + + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + call ESMF_ClockGet(this%clock,currTime=current_time,_RC) + call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) + timeset(1) = current_time - dur + timeset(2) = current_time + call this%get_x_subset(timeset, x_subset, _RC) + is=x_subset(1) + ie=x_subset(2) + !! write(6,'(2x,a,4i10)') 'in regrid_accumulate is, ie=', is, ie + + + ! + ! __ I designed a method to return from regridding if no valid points exist + ! in reality for 29 ioda platforms and dt > 20 sec, we donot need this + ! + !!arr(1)=1 + !!if (.NOT. (is > 0 .AND. is <= ie )) arr(1)=0 + !!call ESMF_VMGetGlobal(vm,_RC) + !!call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) + !!call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & + !! count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + !!if ( nx_sum == 0 ) then + !! write(6, '(2x,a,2x,3i10)') 'invalid points, mypet, is, ie =', mypet, is, ie + !! ! no valid points to regrid + !! _RETURN(ESMF_SUCCESS) + !!else + !! write(6, '(2x,a,2x,3i10)') ' valid points, mypet, is, ie =', mypet, is, ie + !!end if + + + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%setup_eta_to_pressure(_RC) + endif + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) + call ESMF_FieldBundleGet(this%output_bundle,trim(item%xname),field=dst_field,_RC) + call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) + call ESMF_FieldGet(src_field,rank=rank,_RC) + if (rank==2) then + call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) + call ESMF_FieldGet(acc_field,farrayptr=p_acc_2d,_RC) + + !! print*, 'size(src,dst,acc)', size(p_src_2d), size(p_dst_2d), size(p_acc_2d) + call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) + if (is > 0 .AND. is <= ie ) then + p_acc_2d(is:ie) = p_dst_2d(is:ie) + endif + + !!if (is>0) write(6,'(a)') 'regrid_accu: p_dst_2d' + !!if (is>0) write(6,'(10f7.1)') p_dst_2d + + else if (rank==3) then + call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) + call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) + call ESMF_FieldGet(acc_field,farrayptr=p_acc_3d,_RC) + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + allocate(p_new_lev(size(p_src_3d,1),size(p_src_3d,2),this%vdata%lm),_STAT) + call this%vdata%regrid_eta_to_pressure(p_src_3d,p_new_lev,_RC) + call this%regridder%regrid(p_new_lev,p_dst_3d,_RC) + if (is > 0 .AND. is <= ie ) then + p_acc_3d(is:ie,:) = p_dst_3d(is:ie,:) + end if + else + call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) + if (is > 0 .AND. is <= ie ) then + p_acc_3d(is:ie,:) = p_dst_3d(is:ie,:) + end if + end if + end if + else if (item%itemType == ItemTypeVector) then + _FAIL("ItemTypeVector not yet supported") + end if + call iter%next() + enddo + + _RETURN(ESMF_SUCCESS) + + end procedure regrid_accumulate_on_xsubset + + + module procedure destroy_rh_regen_LS + integer :: status + integer :: numVars, i, k + character(len=ESMF_MAXSTR), allocatable :: names(:) + type(ESMF_Field) :: field + type(ESMF_Time) :: currTime + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + call ESMF_FieldDestroy(this%fieldB,nogarbage=.true.,_RC) + call this%locstream_factory%destroy_locstream(this%LS_rt, _RC) + call this%locstream_factory%destroy_locstream(this%LS_ds, _RC) + call this%regridder%destroy(_RC) + deallocate (this%lons, this%lats, & + this%times_R8, this%obstype_id, this%location_index_ioda) + + do k=1, this%nobs_type + deallocate (this%obs(k)%metadata) + if (mapl_am_i_root()) then + deallocate (this%obs(k)%file_handle) + end if + end do + + if (mapl_am_i_root()) then + do k=1, this%nobs_type + if (allocated (this%obs(k)%lons)) then + deallocate (this%obs(k)%lons) + end if + if (allocated (this%obs(k)%lats)) then + deallocate (this%obs(k)%lats) + end if + if (allocated (this%obs(k)%times_R8)) then + deallocate (this%obs(k)%times_R8) + end if + if (allocated (this%obs(k)%location_index_ioda)) then + deallocate (this%obs(k)%location_index_ioda) + end if + if (allocated(this%obs(k)%p2d)) then + deallocate (this%obs(k)%p2d) + endif + if (allocated(this%obs(k)%p3d)) then + deallocate (this%obs(k)%p3d) + endif + end do + end if + + call ESMF_FieldBundleGet(this%acc_bundle,fieldCount=numVars,_RC) + allocate(names(numVars),stat=status) + call ESMF_FieldBundleGet(this%acc_bundle,fieldNameList=names,_RC) + do i=1,numVars + call ESMF_FieldBundleGet(this%acc_bundle,trim(names(i)),field=field,_RC) + call ESMF_FieldDestroy(field,noGarbage=.true., _RC) + enddo + call ESMF_FieldBundleDestroy(this%acc_bundle,noGarbage=.true.,_RC) + + call ESMF_FieldBundleGet(this%output_bundle,fieldCount=numVars,_RC) + allocate(names(numVars),stat=status) + call ESMF_FieldBundleGet(this%output_bundle,fieldNameList=names,_RC) + do i=1,numVars + call ESMF_FieldBundleGet(this%output_bundle,trim(names(i)),field=field,_RC) + call ESMF_FieldDestroy(field,noGarbage=.true., _RC) + enddo + call ESMF_FieldBundleDestroy(this%output_bundle,noGarbage=.true.,_RC) + + + call ESMF_ClockGet ( this%clock, CurrTime=currTime, _RC ) + if (currTime > this%obsfile_end_time) then + this%active = .false. + _RETURN(ESMF_SUCCESS) + end if + + this%epoch_index(1:2)=0 + + call this%initialize(reinitialize=.true., _RC) + + _RETURN(ESMF_SUCCESS) + + end procedure destroy_rh_regen_LS + + + module procedure get_x_subset + type (ESMF_Time) :: T1, T2 + real (ESMF_KIND_R8) :: rT1, rT2 + + integer(ESMF_KIND_I8) :: i1, i2 + integer(ESMF_KIND_I8) :: index1, index2, lb, ub + integer :: jlo, jhi + integer :: status + + T1= interval(1) + T2= interval(2) + call time_esmf_2_nc_int (T1, this%datetime_units, i1, _RC) + call time_esmf_2_nc_int (T2, this%datetime_units, i2, _RC) + rT1=real(i1, kind=ESMF_KIND_R8) + rT2=real(i2, kind=ESMF_KIND_R8) + jlo = 1 + !! + !! I choose UB = N+1 not N, because my sub. bisect find n: Y(n)0 , trim(key)//' is not found in Hsampler CF_loc(:)') - - _RETURN(_SUCCESS) - end function find_config - - - subroutine config_accumulate (this, key, cf, rc) - class(samplerHQ) :: this - type(ESMF_Config), intent(in) :: cf - character(len=*) , intent(in) :: key - integer, intent(out), optional :: rc - integer :: status - - this%ngrid = this%ngrid + 1 - this%CF_loc(this%ngrid)%key = trim(key) - this%CF_loc(this%ngrid)%cf = cf - _RETURN(_SUCCESS) - end subroutine config_accumulate - - - !--------------------------------------------------! - ! __ set - ! - ogrid via grid_manager%make_grid - ! using currTime and HQ%config_grid_save - !--------------------------------------------------! - function create_grid(this, key, currTime, grid_type, rc) result(ogrid) - type (ESMF_Grid) :: ogrid - class(samplerHQ) :: this - character(len=*), intent(in) :: key - type(ESMF_Time), intent(inout) :: currTime - character(len=*), optional, intent(in) :: grid_type - integer, intent(out), optional :: rc - integer :: status - - type(ESMF_Config) :: config_grid - character(len=ESMF_MAXSTR) :: time_string - - - if (present(grid_type)) this%grid_type = trim(grid_type) - config_grid = this%find_config(key) - call ESMF_TimeGet(currTime, timeString=time_string, _RC) - - ! - ! -- the `ESMF_ConfigSetAttribute` shows a risk - ! to overwrite the nextline in config - ! - call ESMF_ConfigSetAttribute( config_grid, trim(time_string), label=trim(key)//'.Epoch_init:', _RC) - - ogrid = grid_manager%make_grid(config_grid, prefix=trim(key)//'.', _RC ) - !! call grid_validate (ogrid,) - - _RETURN(_SUCCESS) - - end function create_grid - - - subroutine regrid_accumulate_on_xysubset (this, sp, rc) - class(samplerHQ) :: this - class(sampler), intent(inout) :: sp - integer, intent(out), optional :: rc - integer :: status - - class(AbstractGridFactory), pointer :: factory - type(ESMF_Time) :: timeset(2) - type(ESMF_Time) :: current_time - type(ESMF_TimeInterval) :: dur - integer :: xy_subset(2,2) - - ! __ s1. get xy_subset - - call ESMF_ClockGet(this%clock,currTime=current_time,_RC) - call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) - timeset(1) = current_time - dur - timeset(2) = current_time - - factory => grid_manager%get_factory(sp%output_grid,_RC) - call factory%get_xy_subset( timeset, xy_subset, _RC) - - ! __ s2. interpolate then save data using xy_mask - - call sp%interp_accumulate_fields (xy_subset, _RC) - - _RETURN(ESMF_SUCCESS) - - end subroutine regrid_accumulate_on_xysubset - - - subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) - implicit none - class(samplerHQ) :: this - class(sampler) :: sp - type (StringGridMap), target, intent(inout) :: output_grids - character(len=*), intent(in) :: key_grid_label - integer, intent(out), optional :: rc - integer :: status - - type(ESMF_Time) :: currTime - type(ESMF_Grid), pointer :: pgrid - type(ESMF_Grid) :: ogrid - character(len=ESMF_MAXSTR) :: key_str - type (StringGridMapIterator) :: iter - character(len=:), pointer :: key - - integer :: i, numVars - character(len=ESMF_MAXSTR), allocatable :: names(:) - type(ESMF_Field) :: field - - if ( .NOT. ESMF_AlarmIsRinging(this%alarm) ) then - _RETURN(ESMF_SUCCESS) - endif - - - !__ s1. destroy ogrid + RH, regen ogrid - - key_str = trim(key_grid_label) - pgrid => output_grids%at(key_str) - - call grid_manager%destroy(pgrid,_RC) - - call ESMF_ClockGet (this%clock, CurrTime=currTime, _RC ) - iter = output_grids%begin() - do while (iter /= output_grids%end()) - key => iter%key() - if (trim(key)==trim(key_str)) then - ogrid = this%create_grid (key_str, currTime, _RC) - call output_grids%set(key, ogrid) - endif - call iter%next() - enddo - - - !__ s2. destroy RH - call sp%regrid_handle%destroy(_RC) - - - - !__ s3. destroy acc_bundle / output_bundle - - call ESMF_FieldBundleGet(sp%acc_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) - call ESMF_FieldBundleGet(sp%acc_bundle,fieldNameList=names,_RC) - do i=1,numVars - call ESMF_FieldBundleGet(sp%acc_bundle,trim(names(i)),field=field,_RC) - call ESMF_FieldDestroy(field,noGarbage=.true., _RC) - enddo - call ESMF_FieldBundleDestroy(sp%acc_bundle,noGarbage=.true.,_RC) - - call ESMF_FieldBundleGet(sp%output_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) - call ESMF_FieldBundleGet(sp%output_bundle,fieldNameList=names,_RC) - do i=1,numVars - call ESMF_FieldBundleGet(sp%output_bundle,trim(names(i)),field=field,_RC) - call ESMF_FieldDestroy(field,noGarbage=.true., _RC) - enddo - call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) - - _RETURN(ESMF_SUCCESS) - - end subroutine destroy_rh_regen_ogrid - - - subroutine fill_time_in_bundle (this, xname, bundle, ogrid, rc) - implicit none - class(samplerHQ) :: this - character(len=*), intent(in) :: xname - type(ESMF_FieldBundle), intent(inout) :: bundle - integer, optional, intent(out) :: rc - integer :: status - - type(ESMF_Grid), intent(in) :: ogrid - class(AbstractGridFactory), pointer :: factory - type(ESMF_Field) :: field - real(kind=ESMF_KIND_R4), pointer :: ptr2d(:,:) - - ! __ get field xname='time' - call ESMF_FieldBundleGet (bundle, xname, field=field, _RC) - call ESMF_FieldGet (field, farrayptr=ptr2d, _RC) - - ! __ obs_time from swath factory - factory => grid_manager%get_factory(ogrid,_RC) - call factory%get_obs_time (ogrid, ptr2d, _RC) - - _RETURN(ESMF_SUCCESS) - - end subroutine fill_time_in_bundle - - - function new_sampler(metadata,input_bundle,output_bundle,write_collection_id,read_collection_id, & - metadata_collection_id,regrid_method,fraction,items,rc) result(GriddedIO) - type(sampler) :: GriddedIO - type(Filemetadata), intent(in), optional :: metadata - type(ESMF_FieldBundle), intent(in), optional :: input_bundle - type(ESMF_FieldBundle), intent(in), optional :: output_bundle - integer, intent(in), optional :: write_collection_id - integer, intent(in), optional :: read_collection_id - integer, intent(in), optional :: metadata_collection_id - integer, intent(in), optional :: regrid_method - integer, intent(in), optional :: fraction - type(GriddedIOitemVector), intent(in), optional :: items - integer, intent(out), optional :: rc - - if (present(metadata)) GriddedIO%metadata=metadata - if (present(input_bundle)) GriddedIO%input_bundle=input_bundle - if (present(output_bundle)) GriddedIO%output_bundle=output_bundle - if (present(regrid_method)) GriddedIO%regrid_method=regrid_method - if (present(write_collection_id)) GriddedIO%write_collection_id=write_collection_id - if (present(read_collection_id)) GriddedIO%read_collection_id=read_collection_id - if (present(metadata_collection_id)) GriddedIO%metadata_collection_id=metadata_collection_id - if (present(items)) GriddedIO%items=items - if (present(fraction)) GriddedIO%fraction=fraction - _RETURN(ESMF_SUCCESS) - end function new_sampler - - - subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) - class (sampler), intent(inout) :: this - type(GriddedIOitemVector), target, intent(inout) :: items - type(ESMF_FieldBundle), intent(inout) :: bundle - character(len=*), intent(in) :: tunit - type(TimeData), optional, intent(inout) :: timeInfo - type(VerticalData), intent(inout), optional :: vdata - type (ESMF_Grid), intent(inout), pointer, optional :: ogrid - integer, intent(out), optional :: rc - - type(ESMF_Grid) :: input_grid - class (AbstractGridFactory), pointer :: factory - - type(ESMF_Field) :: new_field - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - integer :: status - - this%items = items - this%input_bundle = bundle - this%output_bundle = ESMF_FieldBundleCreate(rc=status) - _VERIFY(status) - if(present(timeInfo)) this%timeInfo = timeInfo - call ESMF_FieldBundleGet(this%input_bundle,grid=input_grid,rc=status) - _VERIFY(status) - if (present(ogrid)) then - this%output_grid=ogrid - else - call ESMF_FieldBundleGet(this%input_bundle,grid=this%output_grid,rc=status) - _VERIFY(status) - end if - this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) - _VERIFY(status) - - ! We get the regrid_method here because in the case of Identity, we set it to - ! REGRID_METHOD_IDENTITY in the regridder constructor if identity. Now we need - ! to change the regrid_method in the GriddedIO object to be the same as the - ! the regridder object. - this%regrid_method = this%regrid_handle%get_regrid_method() - - call ESMF_FieldBundleSet(this%output_bundle,grid=this%output_grid,rc=status) - _VERIFY(status) - factory => get_factory(this%output_grid,rc=status) - _VERIFY(status) - - ! __ please note, metadata in this section is not used in put_var to netCDF - ! the design used mGriddedIO%metadata in MAPL_HistoryGridComp.F90 - ! In other words, factory%append_metadata appeared here and in GriddedIO.F90 - ! - if (allocated(this%metadata)) then - deallocate (this%metadata) - end if - allocate(this%metadata) - call factory%append_metadata(this%metadata) - if (present(vdata)) then - this%vdata=vdata - else - this%vdata=VerticalData(rc=status) - _VERIFY(status) - end if - - call this%vdata%append_vertical_metadata(this%metadata,this%input_bundle,rc=status) - _VERIFY(status) - this%doVertRegrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) - if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%input_bundle,rc=status) - _VERIFY(status) - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call this%CreateVariable(item%xname,rc=status) - _VERIFY(status) - else if (item%itemType == ItemTypeVector) then - call this%CreateVariable(item%xname,rc=status) - _VERIFY(status) - call this%CreateVariable(item%yname,rc=status) - _VERIFY(status) - end if - call iter%next() - enddo - - - ! __ add acc_bundle and output_bundle - ! - this%acc_bundle = ESMF_FieldBundleCreate(_RC) - call ESMF_FieldBundleSet(this%acc_bundle,grid=this%output_grid,_RC) - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - call this%addVariable_to_acc_bundle(item%xname,_RC) - if (item%itemType == ItemTypeVector) then - call this%addVariable_to_acc_bundle(item%yname,_RC) - end if - call iter%next() - enddo - - - ! __ add time to acc_bundle - ! - new_field = ESMF_FieldCreate(this%output_grid ,name='time', & - typekind=ESMF_TYPEKIND_R4,_RC) - ! - ! add attribute - ! - call ESMF_AttributeSet(new_field,'UNITS',trim(tunit),_RC) - call MAPL_FieldBundleAdd( this%acc_bundle, new_field, _RC ) - - _RETURN(_SUCCESS) - end subroutine Create_Bundle_RH - - - subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,nbits_to_keep,regrid_method,itemOrder,write_collection_id,rc) - class (sampler), intent(inout) :: this - integer, optional, intent(in) :: deflation - integer, optional, intent(in) :: quantize_algorithm - integer, optional, intent(in) :: quantize_level - integer, optional, intent(in) :: chunking(:) - integer, optional, intent(in) :: nbits_to_keep - integer, optional, intent(in) :: regrid_method - logical, optional, intent(in) :: itemOrder - integer, optional, intent(in) :: write_collection_id - integer, optional, intent(out) :: rc - - integer :: status - - if (present(regrid_method)) this%regrid_method=regrid_method - if (present(nbits_to_keep)) this%nbits_to_keep=nbits_to_keep - if (present(deflation)) this%deflateLevel = deflation - if (present(quantize_algorithm)) this%quantizeAlgorithm = quantize_algorithm - if (present(quantize_level)) this%quantizeLevel = quantize_level - if (present(chunking)) then - allocate(this%chunking,source=chunking,stat=status) - _VERIFY(status) - end if - if (present(itemOrder)) this%itemOrderAlphabetical = itemOrder - if (present(write_collection_id)) this%write_collection_id=write_collection_id - _RETURN(ESMF_SUCCESS) - - end subroutine set_param - - subroutine set_default_chunking(this,rc) - class (sampler), intent(inout) :: this - integer, optional, intent(out) :: rc - - integer :: global_dim(3) - integer :: status - - call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - if (global_dim(1)*6 == global_dim(2)) then - allocate(this%chunking(5)) - this%chunking(1) = global_dim(1) - this%chunking(2) = global_dim(1) - this%chunking(3) = 1 - this%chunking(4) = 1 - this%chunking(5) = 1 - else - allocate(this%chunking(4)) - this%chunking(1) = global_dim(1) - this%chunking(2) = global_dim(2) - this%chunking(3) = 1 - this%chunking(4) = 1 - endif - _RETURN(ESMF_SUCCESS) - - end subroutine set_default_chunking - - subroutine check_chunking(this,lev_size,rc) - class (sampler), intent(inout) :: this - integer, intent(in) :: lev_size - integer, optional, intent(out) :: rc - - integer :: global_dim(3) - integer :: status - character(len=5) :: c1,c2 - - call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) - if (global_dim(1)*6 == global_dim(2)) then - write(c2,'(I5)')global_dim(1) - write(c1,'(I5)')this%chunking(1) - _ASSERT(this%chunking(1) <= global_dim(1), "Chunk for Xdim "//c1//" must be less than or equal to "//c2) - write(c1,'(I5)')this%chunking(2) - _ASSERT(this%chunking(2) <= global_dim(1), "Chunk for Ydim "//c1//" must be less than or equal to "//c2) - _ASSERT(this%chunking(3) <= 6, "Chunksize for face dimension must be 6 or less") - if (lev_size > 0) then - write(c2,'(I5)')lev_size - write(c1,'(I5)')this%chunking(4) - _ASSERT(this%chunking(4) <= lev_size, "Chunk for level size "//c1//" must be less than or equal to "//c2) - end if - _ASSERT(this%chunking(5) == 1, "Time must have chunk size of 1") - else - write(c2,'(I5)')global_dim(1) - write(c1,'(I5)')this%chunking(1) - _ASSERT(this%chunking(1) <= global_dim(1), "Chunk for lon "//c1//" must be less than or equal to "//c2) - write(c2,'(I5)')global_dim(2) - write(c1,'(I5)')this%chunking(2) - _ASSERT(this%chunking(2) <= global_dim(2), "Chunk for lat "//c1//" must be less than or equal to "//c2) - if (lev_size > 0) then - write(c2,'(I5)')lev_size - write(c1,'(I5)')this%chunking(3) - _ASSERT(this%chunking(3) <= lev_size, "Chunk for level size "//c1//" must be less than or equal to "//c2) - end if - _ASSERT(this%chunking(4) == 1, "Time must have chunk size of 1") - endif - _RETURN(ESMF_SUCCESS) - - end subroutine check_chunking - - subroutine CreateVariable(this,itemName,rc) - class (sampler), intent(inout) :: this - character(len=*), intent(in) :: itemName - integer, optional, intent(out) :: rc - - integer :: status - - type(ESMF_Field) :: field,newField - class (AbstractGridFactory), pointer :: factory - integer :: fieldRank - logical :: isPresent - character(len=ESMF_MAXSTR) :: varName,longName,units - - - call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) - _VERIFY(status) - factory => get_factory(this%output_grid,rc=status) - _VERIFY(status) - - - call ESMF_FieldGet(field,rank=fieldRank,rc=status) - _VERIFY(status) - call ESMF_FieldGet(field,name=varName,rc=status) - _VERIFY(status) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=isPresent,rc=status) - _VERIFY(status) - if ( isPresent ) then - call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=LongName, RC=STATUS) - _VERIFY(STATUS) - else - LongName = varName - endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=isPresent,rc=status) - _VERIFY(status) - if ( isPresent ) then - call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, RC=STATUS) - _VERIFY(STATUS) - else - units = 'unknown' - endif - - - ! finally make a new field if neccessary - if (this%doVertRegrid .and. (fieldRank ==3) ) then - newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,rc=status) - _VERIFY(status) - call MAPL_FieldBundleAdd(this%output_bundle,newField,rc=status) - _VERIFY(status) - else - newField = MAPL_FieldCreate(field,this%output_grid,rc=status) - _VERIFY(status) - call MAPL_FieldBundleAdd(this%output_bundle,newField,rc=status) - _VERIFY(status) - end if - _RETURN(_SUCCESS) - - end subroutine CreateVariable - - - subroutine RegridScalar(this,itemName,rc) - class (sampler), intent(inout) :: this - character(len=*), intent(in) :: itemName - integer, optional, intent(out) :: rc - - integer :: status - - type(ESMF_Field) :: field,outField - integer :: fieldRank - real, pointer :: ptr3d(:,:,:),outptr3d(:,:,:) - real, pointer :: ptr2d(:,:), outptr2d(:,:) - real, allocatable, target :: ptr3d_inter(:,:,:) - type(ESMF_Grid) :: gridIn,gridOut - logical :: hasDE_in, hasDE_out - logical :: first_entry - - call ESMF_FieldBundleGet(this%output_bundle,itemName,field=outField,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%output_bundle,grid=gridOut,rc=status) - _VERIFY(status) - hasDE_in = MAPL_GridHasDE(gridIn,rc=status) - _VERIFY(status) - hasDE_out = MAPL_GridHasDE(gridOut,rc=status) - _VERIFY(status) - first_entry = .true. - if (this%doVertRegrid) then - call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(Field,rank=fieldRank,rc=status) - _VERIFY(status) - if (fieldRank==3) then - if (hasDE_in) then - call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) - _VERIFY(status) - else - allocate(ptr3d(0,0,0)) - end if - allocate(ptr3d_inter(size(ptr3d,1),size(ptr3d,2),this%vdata%lm),stat=status) - _VERIFY(status) - if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then - call this%vdata%regrid_select_level(ptr3d,ptr3d_inter,rc=status) - _VERIFY(status) - else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%regrid_eta_to_pressure(ptr3d,ptr3d_inter,rc=status) - _VERIFY(status) - else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then - call this%vdata%flip_levels(ptr3d,ptr3d_inter,rc=status) - _VERIFY(status) - end if - ptr3d => ptr3d_inter - end if - else - if (first_entry) then - nullify(ptr3d) - first_entry = .false. - end if - end if - - call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,rc=status) - _VERIFY(status) - call ESMF_FieldGet(field,rank=fieldRank,rc=status) - _VERIFY(status) - if (fieldRank==2) then - if (hasDE_in) then - call MAPL_FieldGetPointer(field,ptr2d,rc=status) - _VERIFY(status) - else - allocate(ptr2d(0,0)) - end if - if (hasDE_out) then - call MAPL_FieldGetPointer(OutField,outptr2d,rc=status) - _VERIFY(status) - else - allocate(outptr2d(0,0)) - end if - if (gridIn==gridOut) then - outPtr2d=ptr2d - else - if (this%regrid_method==REGRID_METHOD_FRACTION) ptr2d=ptr2d-this%fraction - call this%regrid_handle%regrid(ptr2d,outPtr2d,rc=status) - _VERIFY(status) - end if - -!! print *, maxval(ptr2d) -!! print *, minval(ptr2d) -!! print *, maxval(outptr2d) -!! print *, minval(outptr2d) - - else if (fieldRank==3) then - if (.not.associated(ptr3d)) then - if (hasDE_in) then - call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) - _VERIFY(status) - else - allocate(ptr3d(0,0,0)) - end if - end if - if (hasDE_out) then - call MAPL_FieldGetPointer(OutField,outptr3d,rc=status) - _VERIFY(status) - else - allocate(outptr3d(0,0,0)) - end if - if (gridIn==gridOut) then - outPtr3d=Ptr3d - else - if (this%regrid_method==REGRID_METHOD_FRACTION) ptr3d=ptr3d-this%fraction - call this%regrid_handle%regrid(ptr3d,outPtr3d,rc=status) - _VERIFY(status) - end if - else - _FAIL('rank not supported') - end if - - if (allocated(ptr3d_inter)) deallocate(ptr3d_inter) - _RETURN(_SUCCESS) - - end subroutine RegridScalar - - subroutine RegridVector(this,xName,yName,rc) - class (sampler), intent(inout) :: this - character(len=*), intent(in) :: xName - character(len=*), intent(in) :: yName - integer, optional, intent(out) :: rc - - integer :: status - - type(ESMF_Field) :: xfield,xoutField - type(ESMF_Field) :: yfield,youtField - integer :: fieldRank - real, pointer :: xptr3d(:,:,:),xoutptr3d(:,:,:) - real, pointer :: xptr2d(:,:), xoutptr2d(:,:) - real, allocatable, target :: xptr3d_inter(:,:,:) - real, pointer :: yptr3d(:,:,:),youtptr3d(:,:,:) - real, pointer :: yptr2d(:,:), youtptr2d(:,:) - real, allocatable, target :: yptr3d_inter(:,:,:) - type(ESMF_Grid) :: gridIn, gridOut - logical :: hasDE_in, hasDE_out - - call ESMF_FieldBundleGet(this%output_bundle,xName,field=xoutField,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%output_bundle,yName,field=youtField,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%output_bundle,grid=gridOut,rc=status) - _VERIFY(status) - hasDE_in = MAPL_GridHasDE(gridIn,rc=status) - _VERIFY(status) - hasDE_out = MAPL_GridHasDE(gridOut,rc=status) - _VERIFY(status) - - if (this%doVertRegrid) then - call ESMF_FieldBundleGet(this%input_bundle,xName,field=xfield,rc=status) - _VERIFY(status) - call ESMF_FieldGet(xField,rank=fieldRank,rc=status) - _VERIFY(status) - if (fieldRank==3) then - if (hasDE_in) then - call ESMF_FieldGet(xfield,farrayPtr=xptr3d,rc=status) - _VERIFY(status) - else - allocate(xptr3d(0,0,0)) - end if - allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),stat=status) - _VERIFY(status) - if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then - call this%vdata%regrid_select_level(xptr3d,xptr3d_inter,rc=status) - _VERIFY(status) - else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%regrid_eta_to_pressure(xptr3d,xptr3d_inter,rc=status) - _VERIFY(status) - else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then - call this%vdata%flip_levels(xptr3d,xptr3d_inter,rc=status) - _VERIFY(status) - end if - xptr3d => xptr3d_inter - end if - call ESMF_FieldBundleGet(this%input_bundle,yName,field=yfield,rc=status) - _VERIFY(status) - call ESMF_FieldGet(yField,rank=fieldRank,rc=status) - _VERIFY(status) - if (fieldRank==3) then - if (hasDE_in) then - call ESMF_FieldGet(yfield,farrayPtr=yptr3d,rc=status) - _VERIFY(status) - else - allocate(yptr3d(0,0,0)) - end if - allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),stat=status) - _VERIFY(status) - if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then - call this%vdata%regrid_select_level(yptr3d,yptr3d_inter,rc=status) - _VERIFY(status) - else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%regrid_eta_to_pressure(yptr3d,yptr3d_inter,rc=status) - _VERIFY(status) - else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then - call this%vdata%flip_levels(yptr3d,yptr3d_inter,rc=status) - _VERIFY(status) - end if - yptr3d => yptr3d_inter - end if - else - if (associated(xptr3d)) nullify(xptr3d) - if (associated(yptr3d)) nullify(yptr3d) - end if - - call ESMF_FieldBundleGet(this%input_bundle,xname,field=xfield,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%input_bundle,yname,field=yfield,rc=status) - _VERIFY(status) - call ESMF_FieldGet(xfield,rank=fieldRank,rc=status) - _VERIFY(status) - if (fieldRank==2) then - if (hasDE_in) then - call MAPL_FieldGetPointer(xfield,xptr2d,rc=status) - _VERIFY(status) - call MAPL_FieldGetPointer(yfield,yptr2d,rc=status) - _VERIFY(status) - else - allocate(xptr2d(0,0)) - allocate(yptr2d(0,0)) - end if - - if (hasDE_in) then - call MAPL_FieldGetPointer(xOutField,xoutptr2d,rc=status) - _VERIFY(status) - call MAPL_FieldGetPointer(yOutField,youtptr2d,rc=status) - _VERIFY(status) - else - allocate(xoutptr2d(0,0)) - allocate(youtptr2d(0,0)) - end if - - - if (gridIn==gridOut) then - xoutPtr2d=xptr2d - youtPtr2d=yptr2d - else - call this%regrid_handle%regrid(xptr2d,yptr2d,xoutPtr2d,youtPtr2d,rc=status) - _VERIFY(status) - end if - else if (fieldRank==3) then - if (.not.associated(xptr3d)) then - if (hasDE_in) then - call MAPL_FieldGetPointer(xfield,xptr3d,rc=status) - _VERIFY(status) - else - allocate(xptr3d(0,0,0)) - end if - end if - if (.not.associated(yptr3d)) then - if (hasDE_in) then - call MAPL_FieldGetPointer(yfield,yptr3d,rc=status) - _VERIFY(status) - else - allocate(yptr3d(0,0,0)) - end if - end if - - if (hasDE_out) then - call MAPL_FieldGetPointer(xOutField,xoutptr3d,rc=status) - _VERIFY(status) - call MAPL_FieldGetPointer(yOutField,youtptr3d,rc=status) - _VERIFY(status) - else - allocate(xoutptr3d(0,0,0)) - allocate(youtptr3d(0,0,0)) - end if - - if (gridIn==gridOut) then - xoutPtr3d=xptr3d - youtPtr3d=yptr3d - else - call this%regrid_handle%regrid(xptr3d,yptr3d,xoutPtr3d,youtPtr3d,rc=status) - _VERIFY(status) - end if - end if - - if (allocated(xptr3d_inter)) deallocate(xptr3d_inter) - if (allocated(yptr3d_inter)) deallocate(yptr3d_inter) - _RETURN(_SUCCESS) - - end subroutine RegridVector - - - subroutine alphabatize_variables(this,nfixedVars,rc) - class (sampler), intent(inout) :: this - integer, intent(in) :: nFixedVars - integer, optional, intent(out) :: rc - - type(StringVector) :: order - type(StringVector) :: newOrder - character(len=:), pointer :: v1 - character(len=ESMF_MAXSTR) :: c1,c2 - character(len=ESMF_MAXSTR), allocatable :: temp(:) - logical :: swapped - integer :: n,i - integer :: status - - order = this%metadata%get_order(rc=status) - _VERIFY(status) - n = Order%size() - allocate(temp(nFixedVars+1:n)) - do i=1,n - v1 => order%at(i) - if ( i > nFixedVars) temp(i)=trim(v1) - enddo - - swapped = .true. - do while(swapped) - swapped = .false. - do i=nFixedVars+1,n-1 - c1 = temp(i) - c2 = temp(i+1) - if (c1 > c2) then - temp(i+1)=c1 - temp(i)=c2 - swapped =.true. - end if - enddo - enddo - - do i=1,nFixedVars - v1 => Order%at(i) - call newOrder%push_back(v1) - enddo - do i=nFixedVars+1,n - call newOrder%push_back(trim(temp(i))) - enddo - call this%metadata%set_order(newOrder,rc=status) - _VERIFY(status) - deallocate(temp) - - _RETURN(_SUCCESS) - - end subroutine alphabatize_variables - - - subroutine addVariable_to_acc_bundle(this,itemName,rc) - class (sampler), intent(inout) :: this - character(len=*), intent(in) :: itemName - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field,newField - integer :: fieldRank - integer :: status - - call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) - call ESMF_FieldGet(field,rank=fieldRank,rc=status) - if (this%doVertRegrid .and. (fieldRank ==3) ) then - newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) - else - newField = MAPL_FieldCreate(field,this%output_grid,_RC) - end if - call MAPL_FieldBundleAdd(this%acc_bundle,newField,_RC) - - _RETURN(_SUCCESS) - - end subroutine addVariable_to_acc_bundle - - - subroutine addVariable_to_output_bundle(this,itemName,rc) - class (sampler), intent(inout) :: this - character(len=*), intent(in) :: itemName - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field,newField - integer :: fieldRank - integer :: status - - call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) - call ESMF_FieldGet(field,rank=fieldRank,rc=status) - if (this%doVertRegrid .and. (fieldRank ==3) ) then - newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) - else - newField = MAPL_FieldCreate(field,this%output_grid,_RC) - end if - call MAPL_FieldBundleAdd(this%output_bundle,newField,_RC) - - _RETURN(_SUCCESS) - end subroutine addVariable_to_output_bundle - - - - !! -- based on subroutine bundlepost(this,filename,oClients,rc) - !! - subroutine interp_accumulate_fields (this,xy_subset,rc) - implicit none - class (sampler) :: this - integer, intent(in) :: xy_subset(2,2) - !!integer, intent(in) :: xy_mask(:,:) - integer, optional, intent(out) :: rc - - integer :: status - type(ESMF_Field) :: outField - type(ESMF_Field) :: new_outField - type(ESMF_Grid) :: grid - - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - - type(ESMF_Array) :: array1, array2 - integer :: is,ie,js,je - - integer :: rank - real(KIND=ESMF_KIND_R4), pointer :: pt2d(:,:), pt2d_(:,:) - real(KIND=ESMF_KIND_R4), pointer :: pt3d(:,:,:), pt3d_(:,:,:) - - integer :: localDe, localDECount - integer, dimension(:), allocatable :: LB, UB, exclusiveCount - integer, dimension(:), allocatable :: compLB, compUB, compCount - integer :: dimCount - integer :: y1, y2 - integer :: j, jj - integer :: ii1, iin, jj1, jjn - integer, dimension(:), allocatable :: j1, j2 - - is=xy_subset(1,1); ie=xy_subset(2,1) - js=xy_subset(1,2); je=xy_subset(2,2) - - if (js > je) then - ! no valid points are found on swath grid for this time step - _RETURN(ESMF_SUCCESS) - end if - - if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%setup_eta_to_pressure(regrid_handle=this%regrid_handle,output_grid=this%output_grid,rc=status) - _VERIFY(status) - end if - - call ESMF_FieldBundleGet(this%output_bundle, grid=grid, _RC) - call ESMF_GridGet(grid, localDECount=localDECount, dimCount=dimCount, _RC) - allocate ( LB(dimCount), UB(dimCount), exclusiveCount(dimCount) ) - allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) - - allocate ( j1(0:localDEcount-1) ) ! start - allocate ( j2(0:localDEcount-1) ) ! end - - _ASSERT ( localDEcount == 1, 'failed, due to localDEcount > 1') - call MAPL_GridGetInterior(grid,ii1,iin,jj1,jjn) -!! write(6,*) 'MAPL_GridGetInterior, ii1,iin,jj1,jjn', ii1,iin,jj1,jjn -!! print*, 'js,je ', js, je - - LB(1)=ii1; LB(2)=jj1 - UB(1)=iin; UB(2)=jjn - - do localDe=0, localDEcount-1 - ! - ! is/ie, js/je, [LB, UB] - ! - ! - y1=jj1; y2=jjn - if (y1 < js) then - if (y2 < js) then - j1(localDe)=-1 - j2(localDe)=-1 - elseif (y2 < je) then - j1(localDe)=js - j2(localDe)=y2 - else - j1(localDe)=js - j2(localDe)=je - endif - elseif (y1 <= je) then - j1(localDe)=y1 - if (y2 < je) then - j2(localDe)=y2 - else - j2(localDe)=je - endif - else - j1(localDe)=-1 - j2(localDe)=-1 - endif - enddo - -!! write(6,*) 'ck bundlepost_acc' -!! write(6,*) 'j1(localDe)', j1(0:localDeCount-1) -!! write(6,*) 'j2(localDe)', j2(0:localDeCount-1) - - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call this%RegridScalar(item%xname,rc=status) - _VERIFY(status) - call ESMF_FieldBundleGet(this%output_bundle,item%xname,field=outField, _RC) - _VERIFY(status) - if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%correct_topo(outField,rc=status) - _VERIFY(status) - end if - - ! -- mask the time interval - ! store the time interval fields into new bundle - call ESMF_FieldGet(outField, Array=array1, _RC) - call ESMF_FieldBundleGet(this%acc_bundle,item%xname,field=new_outField,_RC) - call ESMF_FieldGet(new_outField, Array=array2, _RC) - call ESMF_ArrayGet(array1, rank=rank, _RC) - if (rank==2) then - call ESMF_ArrayGet(array1, farrayptr=pt2d, _RC) - call ESMF_ArrayGet(array2, farrayptr=pt2d_, _RC) - localDe=0 - if (j1(localDe)>0) then - do j= j1(localDe), j2(localDe) - jj= j-jj1+1 ! j_local -!! write(6,*) 'j, jj', j, jj - pt2d_(:,jj) = pt2d(:,jj) - enddo - endif - elseif (rank==3) then - call ESMF_ArrayGet(array1, farrayptr=pt3d, _RC) - call ESMF_ArrayGet(array2, farrayptr=pt3d_, _RC) - do localDe=0, localDEcount-1 - if (j1(localDe)>0) then - do j= j1(localDe), j2(localDe) - jj= j-jj1+1 - pt3d_(:,jj,:) = pt3d(:,jj,:) - enddo - endif - enddo - else - _FAIL('failed interp_accumulate_fields') - endif - - else if (item%itemType == ItemTypeVector) then - _FAIL('ItemTypeVector not implemented') - end if - call iter%next() - enddo - - _RETURN(ESMF_SUCCESS) - - end subroutine interp_accumulate_fields - - - subroutine get_xy_mask(grid, xy_subset, xy_mask, rc) - implicit none - type(ESMF_Grid), intent(in) :: grid - integer, intent(in) :: xy_subset(2,2) - integer, intent(out) :: xy_mask(:,:) - integer, optional, intent(out) :: rc - - integer :: status - integer :: ii1, iin, jj1, jjn ! local box for localDE - integer :: is,ie, js, je ! global box for each time-interval - - integer :: y1, y2 - integer :: jj - integer :: j1, j2 - - is=xy_subset(1,1); ie=xy_subset(2,1) - js=xy_subset(1,2); je=xy_subset(2,2) - - call MAPL_GridGetInterior(grid,ii1,iin,jj1,jjn) - write(6,*) 'MAPL_GridGetInterior, ii1,iin,jj1,jjn', ii1,iin,jj1,jjn - - y1=jj1; y2=jjn - if (y1 < js) then - if (y2 < js) then - j1=-1 - j2=-1 - elseif (y2 < je) then - j1=js - j2=y2 - else - j1=js - j2=je - endif - elseif (y1 <= je) then - j1=y1 - if (y2 < je) then - j2=y2 - else - j2=je - endif - else - j1=-1 - j2=-1 - endif - -!! write(6,*) 'get_xy_mask: j1,j2=', j1, j2 - xy_mask(:,:) = 0 - if (j1 > 0) then - do jj = j1, j2 - xy_mask(:, jj) = 1 - enddo - end if - - if(present(rc)) rc=0 - - end subroutine get_xy_mask - - -end module MAPL_EpochSwathMod diff --git a/gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 b/gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 deleted file mode 100644 index 69a83a0ac979..000000000000 --- a/gridcomps/History/MAPL_HistoryMaskGeosatMod.F90 +++ /dev/null @@ -1,179 +0,0 @@ -module MaskSamplerGeosatMod - use ESMF - use MAPL_ErrorHandlingMod - use MAPL_KeywordEnforcerMod - use LocStreamFactoryMod - use MAPL_LocstreamRegridderMod - use MAPL_FileMetadataUtilsMod - use pFIO - use MAPL_GriddedIOItemMod - use MAPL_GriddedIOItemVectorMod - use MAPL_TimeDataMod - use MAPL_VerticalDataMod - use MAPL_BaseMod - use MAPL_CommsMod - use MAPL_SortMod - use MAPL_NetCDF - use MAPL_StringTemplate - use Plain_netCDF_Time - use MAPL_ObsUtilMod - use MPI - use pFIO_FileMetadataMod, only : FileMetadata - use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter - use, intrinsic :: iso_fortran_env, only: REAL32 - use, intrinsic :: iso_fortran_env, only: REAL64 - use pflogger, only: Logger, logging - implicit none - - private - - public :: MaskSamplerGeosat - type :: MaskSamplerGeosat - private - ! character(len=:), allocatable :: grid_file_name - character(len=ESMF_MAXSTR) :: grid_file_name - !-- ygyu we donot need LS - ! - ! we need on each PET - ! npt_mask, index_mask(1:2,npt_mask)=[i,j] - ! - integer :: npt_mask - integer :: npt_mask_tot - integer, allocatable :: index_mask(:,:) - ! - type(ESMF_FieldBundle) :: bundle - type(ESMF_FieldBundle) :: output_bundle - ! type(ESMF_FieldBundle) :: acc_bundle - ! type(ESMF_Field) :: fieldA - ! type(ESMF_Field) :: fieldB - - type(GriddedIOitemVector) :: items - type(VerticalData) :: vdata - logical :: do_vertical_regrid - character(len=ESMF_MAXSTR) :: ofile - type(TimeData) :: time_info - type(ESMF_Clock) :: clock - type(ESMF_Alarm), public :: alarm - type(ESMF_Time) :: RingTime - type(ESMF_TimeInterval) :: epoch_frequency - type(FileMetadata) :: metadata - type(NetCDF4_FileFormatter) :: formatter - - - integer :: nobs_type - integer :: nobs - integer :: obs_written - - character(len=ESMF_MAXSTR) :: index_name_x - character(len=ESMF_MAXSTR) :: index_name_y - character(len=ESMF_MAXSTR) :: index_name_location - character(len=ESMF_MAXSTR) :: index_name_lon - character(len=ESMF_MAXSTR) :: index_name_lat - character(len=ESMF_MAXSTR) :: index_name_loc - character(len=ESMF_MAXSTR) :: var_name_time - character(len=ESMF_MAXSTR) :: var_name_lat - character(len=ESMF_MAXSTR) :: var_name_lon - character(len=ESMF_MAXSTR) :: var_name_x - character(len=ESMF_MAXSTR) :: var_name_y - character(len=ESMF_MAXSTR) :: var_name_proj - character(len=ESMF_MAXSTR) :: att_name_proj - - integer :: xdim_true - integer :: ydim_true - integer :: thin_factor - - integer :: epoch ! unit: second - integer(kind=ESMF_KIND_I8) :: epoch_index(2) - real(kind=REAL64), allocatable :: lons(:) - real(kind=REAL64), allocatable :: lats(:) - integer, allocatable :: recvcounts(:) - integer, allocatable :: displs(:) - - real(kind=ESMF_KIND_R8), pointer:: obsTime(:) - real(kind=ESMF_KIND_R8), allocatable:: t_alongtrack(:) - integer :: nobs_dur - integer :: nobs_dur_sum - type(ESMF_Time) :: obsfile_start_time ! user specify - type(ESMF_Time) :: obsfile_end_time - type(ESMF_TimeInterval) :: obsfile_interval - integer :: obsfile_Ts_index ! for epoch - integer :: obsfile_Te_index - logical :: is_valid - contains - procedure :: initialize - procedure :: add_metadata - procedure :: create_file_handle - procedure :: close_file_handle - procedure :: append_file => regrid_accumulate_append_file -! procedure :: create_new_bundle - procedure :: create_grid => create_Geosat_grid_find_mask - procedure :: compute_time_for_current - end type MaskSamplerGeosat - - interface MaskSamplerGeosat - module procedure MaskSamplerGeosat_from_config - end interface MaskSamplerGeosat - - - interface - module function MaskSamplerGeosat_from_config(config,string,clock,rc) result(mask) - type(MaskSamplerGeosat) :: mask - type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: string - type(ESMF_Clock), intent(in) :: clock - integer, optional, intent(out) :: rc - end function MaskSamplerGeosat_from_config - - module subroutine initialize(this,items,bundle,timeInfo,vdata,reinitialize,rc) - class(MaskSamplerGeosat), intent(inout) :: this - type(GriddedIOitemVector), optional, intent(inout) :: items - type(ESMF_FieldBundle), optional, intent(inout) :: bundle - type(TimeData), optional, intent(inout) :: timeInfo - type(VerticalData), optional, intent(inout) :: vdata - logical, optional, intent(in) :: reinitialize - integer, optional, intent(out) :: rc - end subroutine initialize - - module subroutine create_Geosat_grid_find_mask(this, rc) - class(MaskSamplerGeosat), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine create_Geosat_grid_find_mask - -!! module function create_new_bundle(this,rc) result(new_bundle) -!! class(MaskSamplerGeosat), intent(inout) :: this -!! type(ESMF_FieldBundle) :: new_bundle -!! integer, optional, intent(out) :: rc -!! end function create_new_bundle - - !! module subroutine add_metadata(this,currTime,rc) - module subroutine add_metadata(this,rc) - class(MaskSamplerGeosat), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine add_metadata - - module subroutine create_file_handle(this,filename,rc) - class(MaskSamplerGeosat), intent(inout) :: this - character(len=*), intent(in) :: filename - integer, optional, intent(out) :: rc - end subroutine create_file_handle - - module subroutine close_file_handle(this,rc) - class(MaskSamplerGeosat), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine close_file_handle - - module subroutine regrid_accumulate_append_file(this,current_time,rc) - class(MaskSamplerGeosat), intent(inout) :: this - type(ESMF_Time), intent(inout) :: current_time - integer, optional, intent(out) :: rc - end subroutine regrid_accumulate_append_file - - module function compute_time_for_current(this,current_time,rc) result(rtime) - class(MaskSamplerGeosat), intent(inout) :: this - type(ESMF_Time), intent(in) :: current_time - integer, optional, intent(out) :: rc - real(kind=ESMF_KIND_R8) :: rtime - end function compute_time_for_current - - end interface -end module MaskSamplerGeosatMod diff --git a/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 b/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 deleted file mode 100644 index 3013c4f313ef..000000000000 --- a/gridcomps/History/MAPL_HistoryMaskGeosatMod_smod.F90 +++ /dev/null @@ -1,751 +0,0 @@ -#include "MAPL_ErrLog.h" -#include "unused_dummy.H" - -submodule (MaskSamplerGeosatMod) MaskSamplerGeosat_implement - implicit none -contains - - module procedure MaskSamplerGeosat_from_config - use BinIOMod - use pflogger, only : Logger, logging - type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: epoch_frequency - type(ESMF_TimeInterval) :: obs_time_span - integer :: time_integer, second - integer :: status - character(len=ESMF_MAXSTR) :: STR1, line - character(len=ESMF_MAXSTR) :: symd, shms - integer :: nline, col - integer, allocatable :: ncol(:) - character(len=ESMF_MAXSTR), allocatable :: word(:) - integer :: nobs, head, jvar - logical :: tend - integer :: i, j, k, M - integer :: count - integer :: unitr, unitw - type(Logger), pointer :: lgr - - mask%clock=clock - mask%grid_file_name='' - call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) - if (mapl_am_I_root()) write(6,*) 'string', string - - - call ESMF_ConfigGetAttribute(config, value=mask%grid_file_name,label=trim(string)//'obs_files:', default="", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%index_name_x, label=trim(string)//'index_name_x:', default="x", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%index_name_y, label=trim(string)//'index_name_y:', default="y", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%var_name_x, label=trim(string)//'var_name_x:', default="x", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%var_name_y, label=trim(string)//'var_name_y:', default="y", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%var_name_proj, label=trim(string)//'var_name_proj:',default="", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%att_name_proj, label=trim(string)//'att_name_proj:',default="", _RC) - call ESMF_ConfigGetAttribute(config, value=mask%thin_factor, label=trim(string)//'thin_factor:', default=-1, _RC) - - - if (mapl_am_I_root()) write(6,*) 'thin_factor:', mask%thin_factor - call ESMF_ConfigGetAttribute(config, value=STR1, label=trim(string)//'obs_file_begin:', default="", _RC) - if (trim(STR1)=='') then - mask%obsfile_start_time = currTime - call ESMF_TimeGet(currTime, timestring=STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) - endif - else - call ESMF_TimeSet(mask%obsfile_start_time, STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_begin provided: ', trim(STR1) - end if - end if - - call ESMF_ConfigGetAttribute(config, value=STR1, default="", & - label=trim(string) // 'obs_file_end:', _RC) - if (trim(STR1)=='') then - call ESMF_TimeIntervalSet(obs_time_span, d=14, _RC) - mask%obsfile_end_time = mask%obsfile_start_time + obs_time_span - call ESMF_TimeGet(mask%obsfile_end_time, timestring=STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_end missing, default = begin+14D:', trim(STR1) - endif - else - call ESMF_TimeSet(mask%obsfile_end_time, STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_end provided:', trim(STR1) - end if - end if - - call ESMF_ConfigGetAttribute(config, value=STR1, default="", & - label=trim(string) // 'obs_file_interval:', _RC) - _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') - if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) - - - i= index( trim(STR1), ' ' ) - if (i>0) then - symd=STR1(1:i-1) - shms=STR1(i+1:) - else - symd='' - shms=trim(STR1) - endif - call convert_twostring_2_esmfinterval (symd, shms, mask%obsfile_interval, _RC) - - mask%is_valid = .true. - - _RETURN(_SUCCESS) - -105 format (1x,a,2x,a) -106 format (1x,a,2x,i8) - end procedure MaskSamplerGeosat_from_config - - - ! - !-- integrate both initialize and reinitialize - ! - module procedure initialize - integer :: status - type(ESMF_Grid) :: grid - type(variable) :: v - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_Time) :: currTime - integer :: k - - if (.not. present(reinitialize)) then - if(present(bundle)) this%bundle=bundle - if(present(items)) this%items=items - if(present(timeInfo)) this%time_info=timeInfo - if (present(vdata)) then - this%vdata=vdata - else - this%vdata=VerticalData(_RC) - end if - end if - -! this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) -! if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) - - this%ofile = '' - this%obs_written = 0 - - call this%create_grid(_RC) - call this%add_metadata(_RC) - - _RETURN(_SUCCESS) - - end procedure initialize - - - module procedure create_Geosat_grid_find_mask - use pflogger, only: Logger, logging - implicit none - type(Logger), pointer :: lgr - real(ESMF_KIND_R8), pointer :: ptAT(:) - type(ESMF_routehandle) :: RH - type(ESMF_Grid) :: grid - integer :: mypet, npes - integer :: iroot, rootpet, ierr - type (ESMF_LocStream) :: LS_rt - type (ESMF_LocStream) :: LS_ds - type (LocStreamFactory):: locstream_factory - type (ESMF_Field) :: fieldA - type (ESMF_Field) :: fieldB - - integer :: i, j, k, L - integer :: n1, n2 - integer :: nx, ny, nx_sum - integer :: nlon, nlat - integer :: arr(1) - integer :: len - - integer :: IM, JM, LM, COUNTS(3) - type(ESMF_DistGrid) :: distGrid - type(ESMF_DElayout) :: layout - type(ESMF_VM) :: VM - integer :: myid - integer :: ndes - integer :: dimCount - integer, allocatable :: II(:) - integer, allocatable :: JJ(:) - real(REAL64), allocatable :: obs_lons(:) - real(REAL64), allocatable :: obs_lats(:) - integer :: mpic - - type (ESMF_Field) :: fieldI4 - type(ESMF_routehandle) :: RH_halo - type(ESMF_Field) :: src_field,dst_field,acc_field - integer :: useableHalo_width - integer :: rank - integer :: eLB(2), eUB(2) - integer :: cLB(2), cUB(2) - integer :: tLB(2), tUB(2) - integer :: ecount(2) - integer :: ccount(2) - integer :: tcount(2) - integer(ESMF_KIND_I4), pointer :: farrayPtr(:,:) - real(ESMF_KIND_R8), pointer :: ptA(:) => NULL() - real(ESMF_KIND_R8), pointer :: ptB(:) => NULL() - - character(len=50) :: filename - integer :: unit - integer :: ix, jx - integer :: i_1, i_n, j_1, j_n - real(REAL64), pointer :: x(:) - real(REAL64), pointer :: y(:) - real(REAL64) :: lambda0_deg, lambda0 - real(REAL64) :: x0, y0 - real(REAL64) :: lon0, lat0 - real(REAL64) :: lam_sat - integer :: mask0 - character(len=ESMF_MAXSTR) :: fn, key_x, key_y, key_p, key_p_att - integer :: Xdim_true, Ydim_true - integer :: Xdim_red, Ydim_red - real(REAL64), allocatable :: lons(:), lats(:) - real(REAL64), allocatable :: lons_ds(:), lats_ds(:) - integer, allocatable :: mask(:,:) - - real(ESMF_kind_R8), pointer :: lons_ptr(:,:), lats_ptr(:,:) - integer :: nsend - integer, allocatable :: recvcounts_loc(:) - integer, allocatable :: displs_loc(:) - integer :: status - - lgr => logging%get_logger('HISTORY.sampler') - - ! Metacode: - ! read ABI grid into LS_rt - ! gen LS_ds with CS background grid - ! find mask points on each PET with halo - ! prepare recvcounts + displs for gatherv - ! - - if (mapl_am_i_root()) then - ! __s1. SAT file - ! - fn = this%grid_file_name - key_x = this%var_name_x - key_y = this%var_name_y - key_p = this%var_name_proj - key_p_att = this%att_name_proj - call get_ncfile_dimension(fn,nlon=n1,nlat=n2,key_lon=key_x,key_lat=key_y,_RC) - ! - ! use thin_factor to reduce regridding matrix size - ! - xdim_true = n1 - ydim_true = n2 - xdim_red = n1 / this%thin_factor - ydim_red = n2 / this%thin_factor - allocate (x (xdim_true) ) - allocate (y (xdim_true) ) - - call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) - call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) - call get_att_real_netcdf (fn, key_p, key_p_att, lambda0_deg, _RC) - lam_sat = lambda0_deg * MAPL_DEGREES_TO_RADIANS_R8 - - nx=0 - do i=1, xdim_red - do j=1, ydim_red - x0 = x( i * this%thin_factor ) - y0 = y( j * this%thin_factor ) - call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) - if (mask0 > 0) then - nx=nx+1 - end if - end do - end do - allocate (lons(nx), lats(nx)) - nx = 0 - do i=1, xdim_red - do j=1, ydim_red - x0 = x( i * this%thin_factor ) - y0 = y( j * this%thin_factor ) - call ABI_XY_2_lonlat (x0, y0, lam_sat, lon0, lat0, mask=mask0) - if (mask0 > 0) then - nx=nx+1 - lons(nx) = lon0 * MAPL_RADIANS_TO_DEGREES - lats(nx) = lat0 * MAPL_RADIANS_TO_DEGREES - end if - end do - end do - arr(1)=nx - else - allocate(lons(0),lats(0),_STAT) - arr(1)=0 - endif - - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm, mpiCommunicator=mpic, petcount=npes, localpet=mypet, _RC) - call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx, & - count=1, reduceflag=ESMF_REDUCE_SUM, _RC) - this%nobs = nx - if (mapl_am_I_root()) write(6,*) 'nobs tot :', nx - - if ( nx == 0 ) then - this%is_valid = .false. - _RETURN(ESMF_SUCCESS) - ! - ! no valid obs points are found - ! - end if - - - ! __ s2. set distributed LS - ! - locstream_factory = LocStreamFactory(lons,lats,_RC) - LS_rt = locstream_factory%create_locstream(_RC) - call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - LS_ds = locstream_factory%create_locstream(grid=grid,_RC) - - fieldA = ESMF_FieldCreate (LS_rt, name='A', typekind=ESMF_TYPEKIND_R8, _RC) - fieldB = ESMF_FieldCreate (LS_ds, name='B', typekind=ESMF_TYPEKIND_R8, _RC) - - call ESMF_FieldGet( fieldA, localDE=0, farrayPtr=ptA) - call ESMF_FieldGet( fieldB, localDE=0, farrayPtr=ptB) - if (mypet == 0) then - ptA(:) = lons(:) - end if - call ESMF_FieldRedistStore (fieldA, fieldB, RH, _RC) - call ESMF_FieldRedist (fieldA, fieldB, RH, _RC) - lons_ds = ptB - - if (mypet == 0) then - ptA(:) = lats(:) - end if - call ESMF_FieldRedist (fieldA, fieldB, RH, _RC) - lats_ds = ptB - - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - call ESMF_FieldDestroy(fieldA,nogarbage=.true.,_RC) - call ESMF_FieldDestroy(fieldB,nogarbage=.true.,_RC) - - - ! __ s3. find n.n. CS pts for LS_ds (halo) - ! - obs_lons = lons_ds * MAPL_DEGREES_TO_RADIANS_R8 - obs_lats = lats_ds * MAPL_DEGREES_TO_RADIANS_R8 - nx = size ( lons_ds ) - allocate ( II(nx), JJ(nx) ) - call MPI_Barrier(mpic, status) - call MAPL_GetHorzIJIndex(nx,II,JJ,lonR8=obs_lons,latR8=obs_lats,grid=grid,_RC) - call ESMF_VMBarrier (vm, _RC) - - ! - ! __ halo for mask - ! - call MAPL_GridGet(grid, localCellCountPerDim=COUNTS, _RC) - IM= COUNTS(1) - JM= COUNTS(2) - LM= COUNTS(3) - useableHalo_width = 1 - fieldI4 = ESMF_FieldCreate (grid, ESMF_TYPEKIND_I4, & - totalLwidth=[useableHalo_width,useableHalo_width],& - totalUwidth=[useableHalo_width,useableHalo_width], _RC) - call ESMF_FieldGetBounds (fieldI4, & - exclusiveLBound=eLB, exclusiveUBound=eUB, exclusiveCount=ecount, & - totalLBound=tLB, totalUBound=tUB, totalCount=tcount, & - computationalLBound=cLB, computationalUBound=cUB, computationalCount=ccount, & - _RC) - call ESMF_FieldGet (fieldI4, farrayPtr=farrayPtr, _RC) - farrayPtr(:,:) = 0 - do i=1, nx - if ( II(i)>0 .AND. JJ(i)>0 ) then - farrayPtr( II(i), JJ(i) ) = 1 - endif - enddo - - call ESMF_FieldHaloStore (fieldI4, routehandle=RH_halo, _RC) - call ESMF_FieldHalo (fieldI4, routehandle=RH_halo, _RC) - call ESMF_VMBarrier (vm, _RC) - - k=0 - do i=eLB(1), eUB(1) - do j=eLB(2), eUB(2) - if ( farrayPtr(i,j)==0 .AND. ( & - farrayPtr(i-1,j)==1 .OR. & - farrayPtr(i+1,j)==1 .OR. & - farrayPtr(i,j-1)==1 .OR. & - farrayPtr(i,j+1)==1 ) ) then - farrayPtr(i,j) = -1 - end if - if (farrayPtr(i,j)/=0) k=k+1 - end do - end do - allocate( mask(IM, JM)) - mask(1:IM, 1:JM) = abs(farrayPtr(1:IM, 1:JM)) - - this%npt_mask = k - allocate( this%index_mask(2,k) ) - arr(1)=k - call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=this%npt_mask_tot, & - count=1, reduceflag=ESMF_REDUCE_SUM, _RC) - - k=0 - do i=1, IM - do j=1, JM - if ( mask(i,j)==1 ) then - k=k+1 - this%index_mask(1,k) = i - this%index_mask(2,k) = j - end if - end do - end do - - - ! ---- - ! regridding is replaced by - ! - selecting masked data on PET - ! - mpi_gatherV - ! - - - ! __ s4.1 find this%lons/lats on root for NC output - ! - call ESMF_GridGetCoord (grid, coordDim=1, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lons_ptr, _RC) - call ESMF_GridGetCoord (grid, coordDim=2, localDE=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lats_ptr, _RC) - deallocate (lons, lats) - allocate (lons(this%npt_mask), lats(this%npt_mask)) - do i=1, this%npt_mask - ix=this%index_mask(1,i) - jx=this%index_mask(2,i) - lons(i) = lons_ptr (ix, jx) - lats(i) = lats_ptr (ix, jx) - end do - call ESMF_VMBarrier (vm, _RC) - - iroot=0 - if (mapl_am_i_root()) then - allocate (this%lons(this%npt_mask_tot), this%lats(this%npt_mask_tot)) - else - allocate (this%lons(0), this%lats(0)) - end if - - - ! __ s4.2 find this%recvcounts / this%displs - ! - allocate( this%recvcounts(npes), this%displs(npes) ) - allocate( recvcounts_loc(npes), displs_loc(npes) ) - recvcounts_loc(:)=1 - displs_loc(1)=0 - do i=2, npes - displs_loc(i) = displs_loc(i-1) + recvcounts_loc(i-1) - end do - call MPI_gatherv ( this%npt_mask, 1, MPI_INTEGER, & - this%recvcounts, recvcounts_loc, displs_loc, MPI_INTEGER,& - iroot, mpic, ierr ) - if (.not. mapl_am_i_root()) then - this%recvcounts(:) = 0 - end if - this%displs(1)=0 - do i=2, npes - this%displs(i) = this%displs(i-1) + this%recvcounts(i-1) - end do - - - ! __ s4.3 gatherv lons/lats - ! - nsend=this%npt_mask - call MPI_gatherv ( lons, nsend, MPI_REAL8, & - this%lons, this%recvcounts, this%displs, MPI_REAL8,& - iroot, mpic, ierr ) - call MPI_gatherv ( lats, nsend, MPI_REAL8, & - this%lats, this%recvcounts, this%displs, MPI_REAL8,& - iroot, mpic, ierr ) - - _RETURN(_SUCCESS) - end procedure create_Geosat_grid_find_mask - - -module procedure add_metadata - type(variable) :: v - type(ESMF_Field) :: field - integer :: fieldCount - integer :: field_rank - integer :: nstation - logical :: is_present - integer :: ub(ESMF_MAXDIM) - integer :: lb(ESMF_MAXDIM) - logical :: do_vertical_regrid - integer :: status - integer :: i - - character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) - character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims - character(len=40) :: datetime_units - - !__ 1. metadata add_dimension, - ! add_variable for time, latlon, mask_points - ! - call this%vdata%append_vertical_metadata(this%metadata,this%bundle,_RC) ! specify lev in fmd - call this%time_info%add_time_to_metadata(this%metadata,_RC) - call this%metadata%add_dimension('mask_index', this%npt_mask_tot) - - v = Variable(type=pFIO_REAL64, dimensions='mask_index') - call v%add_attribute('long_name','longitude') - call v%add_attribute('unit','degree_east') - call this%metadata%add_variable('longitude',v) - - v = Variable(type=pFIO_REAL64, dimensions='mask_index') - call v%add_attribute('long_name','latitude') - call v%add_attribute('unit','degree_north') - call this%metadata%add_variable('latitude',v) - - ! To be added when values are available - !v = Variable(type=pFIO_INT32, dimensions='mask_index') - !call v%add_attribute('long_name','The Cubed Sphere Global Face ID') - !call this%metadata%add_variable('mask_CS_Face_ID',v) - ! - !v = Variable(type=pFIO_INT32, dimensions='mask_index') - !call v%add_attribute('long_name','The Cubed Sphere Global Index I') - !call this%metadata%add_variable('mask_CS_global_index_I',v) - ! - !v = Variable(type=pFIO_INT32, dimensions='mask_index') - !call v%add_attribute('long_name','The Cubed Sphere Global Index J') - !call this%metadata%add_variable('mask_CS_global_index_J',v) - - - !__ 2. filemetadata: extract field from bundle, add_variable to metadata - ! - call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount)) - call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) - do i=1, fieldCount - var_name=trim(fieldNameList(i)) - call ESMF_FieldBundleGet(this%bundle,var_name,field=field,_RC) - call ESMF_FieldGet(field,rank=field_rank,_RC) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) - else - long_name = var_name - endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) - else - units = 'unknown' - endif - if (field_rank==2) then - vdims = "mask_index,time" - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[this%npt_mask_tot,1]) - else if (field_rank==3) then - vdims = "lev,mask_index,time" - call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) - end if - call v%add_attribute('units', trim(units)) - call v%add_attribute('long_name', trim(long_name)) - call v%add_attribute('missing_value', MAPL_UNDEF) - call v%add_attribute('_FillValue', MAPL_UNDEF) - call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) - call this%metadata%add_variable(trim(var_name),v,_RC) - end do - deallocate (fieldNameList) - - _RETURN(_SUCCESS) - end procedure add_metadata - - - module procedure regrid_accumulate_append_file - ! - implicit none - integer :: status - integer :: fieldCount - integer :: ub(1), lb(1) - type(ESMF_Field) :: src_field,dst_field - real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) - real(kind=REAL32), allocatable :: p_dst_3d(:),p_dst_2d(:) - real(kind=REAL32), allocatable :: p_dst_3d_full(:),p_dst_2d_full(:) - real(kind=REAL32), allocatable :: arr(:,:) - character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) - character(len=ESMF_MAXSTR) :: xname - real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) - integer :: i, j, k, rank - integer :: nx, nz - integer :: ix, iy, m - integer :: mypet, npes, nsend - integer :: iroot, ierr - integer :: mpic - integer, allocatable :: recvcounts_3d(:) - integer, allocatable :: displs_3d(:) - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_VM) :: vm - - this%obs_written=this%obs_written+1 - - ! -- fixed for all fields - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm, mpiCommunicator=mpic, petcount=npes, localpet=mypet, _RC) - iroot=0 - nx = this%npt_mask - nz = this%vdata%lm - allocate(p_dst_2d (nx)) - allocate(p_dst_3d (nx * nz)) - if (mapl_am_i_root()) then - allocate ( p_dst_2d_full (this%npt_mask_tot) ) - allocate ( p_dst_3d_full (this%npt_mask_tot * nz) ) - else - allocate ( p_dst_2d_full (0) ) - allocate ( p_dst_3d_full (0) ) - end if - allocate( recvcounts_3d(npes), displs_3d(npes) ) - recvcounts_3d(:) = nz * this%recvcounts(:) - displs_3d(:) = nz * this%displs(:) - - - !__ 1. put_var: time variable - ! - allocate( rtimes(1) ) - rtimes(1) = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file - if (mapl_am_i_root()) then - call this%formatter%put_var('time',rtimes(1:1),& - start=[this%obs_written],count=[1],_RC) - end if - - - !__ 2. put_var: ungridded_dim from src to dst [use index_mask] - ! - ! Currently mask only pickup values - ! It does not support vertical regridding - ! - !if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - ! call this%vdata%setup_eta_to_pressure(_RC) - !endif - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) - call ESMF_FieldGet(src_field,rank=rank,_RC) - if (rank==2) then - call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) - do j=1, nx - ix = this%index_mask(1,j) - iy = this%index_mask(2,j) - p_dst_2d(j) = p_src_2d(ix, iy) - end do - call MPI_Barrier(mpic, status) - nsend = nx - call MPI_gatherv ( p_dst_2d, nsend, MPI_REAL, & - p_dst_2d_full, this%recvcounts, this%displs, MPI_REAL,& - iroot, mpic, ierr ) - if (mapl_am_i_root()) then - call this%formatter%put_var(item%xname,p_dst_2d_full,& - start=[1,this%obs_written],count=[this%npt_mask_tot,1],_RC) - end if - else if (rank==3) then - call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) - call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - _ASSERT (this%vdata%lm == (ub(1)-lb(1)+1), 'vertical level is different from CS grid') - m=0 - do j=1, nx - ix = this%index_mask(1,j) - iy = this%index_mask(2,j) - do k= lb(1), ub(1) - m = m + 1 - p_dst_3d(m) = p_src_3d(ix, iy, k) - end do - end do - call MPI_Barrier(mpic, status) - !! write(6,'(2x,a,2x,i5,3x,10f8.1)') 'pet, p_dst_3d(j)', mypet, p_dst_3d(::10) - nsend = nx * nz - call MPI_gatherv ( p_dst_3d, nsend, MPI_REAL, & - p_dst_3d_full, recvcounts_3d, displs_3d, MPI_REAL,& - iroot, mpic, ierr ) - if (mapl_am_i_root()) then - allocate(arr(nz, this%npt_mask_tot)) - arr=reshape(p_dst_3d_full,[nz,this%npt_mask_tot],order=[1,2]) - call this%formatter%put_var(item%xname,arr,& - start=[1,1,this%obs_written],count=[nz,this%npt_mask_tot,1],_RC) - !note: lev,station,time - deallocate(arr) - end if - else - _FAIL('grid2LS regridder: rank > 3 not implemented') - end if - end if - - call iter%next() - end do - - _RETURN(_SUCCESS) - end procedure regrid_accumulate_append_file - - - - module procedure create_file_handle - type(variable) :: v - integer :: status, j - real(kind=REAL64), allocatable :: x(:) - integer :: nx - - this%ofile = trim(filename) - v = this%time_info%define_time_variable(_RC) - call this%metadata%modify_variable('time',v,_RC) - this%obs_written = 0 - - if (.not. mapl_am_I_root()) then - _RETURN(_SUCCESS) - end if - - call this%formatter%create(trim(filename),_RC) - call this%formatter%write(this%metadata,_RC) - - nx = size (this%lons) - allocate ( x(nx) ) - x(:) = this%lons(:) * MAPL_RADIANS_TO_DEGREES - call this%formatter%put_var('longitude',x,_RC) - x(:) = this%lats(:) * MAPL_RADIANS_TO_DEGREES - call this%formatter%put_var('latitude',x,_RC) -! call this%formatter%put_var('mask_id',this%mask_id,_RC) -! call this%formatter%put_var('mask_name',this%mask_name,_RC) - - _RETURN(_SUCCESS) - end procedure create_file_handle - - - module procedure close_file_handle - integer :: status - if (trim(this%ofile) /= '') then - if (mapl_am_i_root()) then - call this%formatter%close(_RC) - end if - end if - _RETURN(_SUCCESS) - end procedure close_file_handle - - - module procedure compute_time_for_current - use MAPL_NetCDF, only : convert_NetCDF_DateTime_to_ESMF - integer :: status - type(ESMF_TimeInterval) :: t_interval - class(Variable), pointer :: var - type(Attribute), pointer :: attr - class(*), pointer :: pTimeUnits - character(len=ESMF_MAXSTR) :: datetime_units - character(len=ESMF_MAXSTR) :: tunit - type(ESMF_time), allocatable :: esmf_time_1d(:) - real(kind=ESMF_KIND_R8), allocatable :: rtime_1d(:) - - var => this%metadata%get_variable('time',_RC) - attr => var%get_attribute('units') - ptimeUnits => attr%get_value() - select type(pTimeUnits) - type is (character(*)) - datetime_units = ptimeUnits - class default - _FAIL("Time unit must be character") - end select - allocate ( esmf_time_1d(1), rtime_1d(1) ) - esmf_time_1d(1)= current_time - call time_ESMF_to_real ( rtime_1d, esmf_time_1d, datetime_units, _RC ) - rtime = rtime_1d(1) - - _RETURN(_SUCCESS) - end procedure compute_time_for_current - - - -end submodule MaskSamplerGeosat_implement diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 deleted file mode 100644 index ab646a3ea0d3..000000000000 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod.F90 +++ /dev/null @@ -1,162 +0,0 @@ -module HistoryTrajectoryMod - use ESMF - use MAPL_FileMetadataUtilsMod - use MAPL_GriddedIOItemVectorMod - use MAPL_TimeDataMod - use MAPL_VerticalDataMod - use LocStreamFactoryMod - use MAPL_LocstreamRegridderMod - use MAPL_ObsUtilMod - use, intrinsic :: iso_fortran_env, only: REAL64 - implicit none - - private - - public :: HistoryTrajectory - type :: HistoryTrajectory - private - type(ESMF_LocStream) :: LS_rt - type(ESMF_LocStream) :: LS_ds - type(LocStreamFactory) :: locstream_factory - type(obs_unit), allocatable :: obs(:) - type(ESMF_Time), allocatable :: times(:) - real(kind=REAL64), allocatable :: lons(:) - real(kind=REAL64), allocatable :: lats(:) - real(kind=REAL64), allocatable :: times_R8(:) - integer, allocatable :: obstype_id(:) - integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file - - type(ESMF_FieldBundle) :: bundle - type(ESMF_FieldBundle) :: output_bundle - type(ESMF_FieldBundle) :: acc_bundle - type(ESMF_Field) :: fieldA - type(ESMF_Field) :: fieldB - - type(GriddedIOitemVector) :: items - type(VerticalData) :: vdata - logical :: do_vertical_regrid - - type(LocstreamRegridder) :: regridder - type(TimeData) :: time_info - type(ESMF_Clock) :: clock - type(ESMF_Alarm), public :: alarm - type(ESMF_Time) :: RingTime - type(ESMF_TimeInterval), public :: epoch_frequency - - integer :: nobs_type -! character(len=ESMF_MAXSTR) :: nc_index -! character(len=ESMF_MAXSTR) :: nc_time -! character(len=ESMF_MAXSTR) :: nc_latitude -! character(len=ESMF_MAXSTR) :: nc_longitude - - character(len=ESMF_MAXSTR) :: index_name_x - character(len=ESMF_MAXSTR) :: var_name_time - character(len=ESMF_MAXSTR) :: var_name_lat - character(len=ESMF_MAXSTR) :: var_name_lon - character(len=ESMF_MAXSTR) :: var_name_time_full - character(len=ESMF_MAXSTR) :: var_name_lat_full - character(len=ESMF_MAXSTR) :: var_name_lon_full - character(len=ESMF_MAXSTR) :: datetime_units - character(len=ESMF_MAXSTR) :: Location_index_name - integer :: epoch ! unit: second - integer(kind=ESMF_KIND_I8) :: epoch_index(2) - real(kind=ESMF_KIND_R8), pointer:: obsTime(:) - integer :: nobs_epoch - integer :: nobs_epoch_sum - type(ESMF_Time) :: obsfile_start_time ! user specify - type(ESMF_Time) :: obsfile_end_time - type(ESMF_TimeInterval) :: obsfile_interval - integer :: obsfile_Ts_index ! for epoch - integer :: obsfile_Te_index - logical :: active - contains - procedure :: initialize => initialize_ - procedure :: create_variable => create_metadata_variable - procedure :: create_file_handle - procedure :: close_file_handle - procedure :: append_file - procedure :: create_new_bundle - procedure :: create_grid - procedure :: regrid_accumulate => regrid_accumulate_on_xsubset - procedure :: destroy_rh_regen_LS - procedure :: get_x_subset - end type HistoryTrajectory - - interface HistoryTrajectory - module procedure HistoryTrajectory_from_config - end interface HistoryTrajectory - - - interface - module function HistoryTrajectory_from_config(config,string,clock,rc) result(traj) - type(HistoryTrajectory) :: traj - type(ESMF_Config), intent(inout) :: config - character(len=*), intent(in) :: string - type(ESMF_Clock), intent(in) :: clock - integer, optional, intent(out) :: rc - end function HistoryTrajectory_from_config - - module subroutine initialize_(this,items,bundle,timeInfo,vdata,reinitialize,rc) - class(HistoryTrajectory), intent(inout) :: this - type(GriddedIOitemVector), optional, intent(inout) :: items - type(ESMF_FieldBundle), optional, intent(inout) :: bundle - type(TimeData), optional, intent(inout) :: timeInfo - type(VerticalData), optional, intent(inout) :: vdata - logical, optional, intent(in) :: reinitialize - integer, optional, intent(out) :: rc - end subroutine initialize_ - - module subroutine create_metadata_variable(this,vname,rc) - class(HistoryTrajectory), intent(inout) :: this - character(len=*), intent(in) :: vname - integer, optional, intent(out) :: rc - end subroutine create_metadata_variable - - module function create_new_bundle(this,rc) result(new_bundle) - class(HistoryTrajectory), intent(inout) :: this - type(ESMF_FieldBundle) :: new_bundle - integer, optional, intent(out) :: rc - end function create_new_bundle - - module subroutine create_file_handle(this,filename_suffix,rc) - class(HistoryTrajectory), intent(inout) :: this - character(len=*), intent(in) :: filename_suffix - integer, optional, intent(out) :: rc - end subroutine create_file_handle - - module subroutine close_file_handle(this,rc) - class(HistoryTrajectory), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine close_file_handle - - module subroutine append_file(this,current_time,rc) - class(HistoryTrajectory), intent(inout) :: this - type(ESMF_Time), intent(inout) :: current_time - integer, optional, intent(out) :: rc - end subroutine append_file - - module subroutine create_grid(this, rc) - class(HistoryTrajectory), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine create_grid - - module subroutine regrid_accumulate_on_xsubset (this, rc) - implicit none - class(HistoryTrajectory), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine regrid_accumulate_on_xsubset - - module subroutine get_x_subset(this, interval, x_subset, rc) - class(HistoryTrajectory), intent(inout) :: this - type(ESMF_Time), intent(in) :: interval(2) - integer, intent(out) :: x_subset(2) - integer, optional, intent(out) :: rc - end subroutine get_x_subset - - module subroutine destroy_rh_regen_LS (this, rc) - class(HistoryTrajectory), intent(inout) :: this - integer, optional, intent(out) :: rc - end subroutine destroy_rh_regen_LS - - end interface -end module HistoryTrajectoryMod diff --git a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 b/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 deleted file mode 100644 index 165c40a42331..000000000000 --- a/gridcomps/History/MAPL_HistoryTrajectoryMod_smod.F90 +++ /dev/null @@ -1,1275 +0,0 @@ -#include "MAPL_ErrLog.h" -#include "unused_dummy.H" - -submodule (HistoryTrajectoryMod) HistoryTrajectory_implement - use ESMF - use MAPL_ErrorHandlingMod - use MAPL_KeywordEnforcerMod - use LocStreamFactoryMod - use MAPL_LocstreamRegridderMod - use MAPL_FileMetadataUtilsMod - use pFIO - use MAPL_GriddedIOItemMod - use MAPL_GriddedIOItemVectorMod - use MAPL_TimeDataMod - use MAPL_VerticalDataMod - use MAPL_BaseMod - use MAPL_CommsMod - use MAPL_SortMod - use MAPL_NetCDF - use MAPL_StringTemplate - use Plain_netCDF_Time - use MAPL_ObsUtilMod - use, intrinsic :: iso_fortran_env, only: REAL32 - use, intrinsic :: iso_fortran_env, only: REAL64 - implicit none - - contains - - module procedure HistoryTrajectory_from_config - use BinIOMod - use pflogger, only : Logger, logging - type(ESMF_Time) :: currTime - type(ESMF_TimeInterval) :: epoch_frequency - type(ESMF_TimeInterval) :: obs_time_span - integer :: time_integer, second - integer :: status - character(len=ESMF_MAXSTR) :: STR1, line - character(len=ESMF_MAXSTR) :: symd, shms - integer :: nline, col - integer, allocatable :: ncol(:) - character(len=ESMF_MAXSTR), allocatable :: word(:) - integer :: nobs, head, jvar - logical :: tend - integer :: i, j, k, M - integer :: count - integer :: unitr, unitw - type(Logger), pointer :: lgr - - traj%clock=clock - call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) - call ESMF_ConfigGetAttribute(config, value=time_integer, label=trim(string)//'Epoch:', default=0, _RC) - _ASSERT(time_integer /= 0, 'Epoch value in config wrong') - second = hms_2_s(time_integer) - call ESMF_TimeIntervalSet(epoch_frequency, s=second, _RC) - traj%Epoch = time_integer - traj%RingTime = currTime - traj%epoch_frequency = epoch_frequency - traj%alarm = ESMF_AlarmCreate( clock=clock, RingInterval=epoch_frequency, & - RingTime=traj%RingTime, sticky=.false., _RC ) - - call ESMF_ConfigGetAttribute(config, value=traj%index_name_x, default="", & - label=trim(string) // 'index_name_x:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%var_name_lon_full, default="", & - label=trim(string) // 'var_name_lon:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%var_name_lat_full, default="", & - label=trim(string) // 'var_name_lat:', _RC) - call ESMF_ConfigGetAttribute(config, value=traj%var_name_time_full, default="", & - label=trim(string) // 'var_name_time:', _RC) - - call ESMF_ConfigGetAttribute(config, value=STR1, default="", & - label=trim(string) // 'obs_file_begin:', _RC) - if (trim(STR1)=='') then - traj%obsfile_start_time = currTime - call ESMF_TimeGet(currTime, timestring=STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_begin missing, default = currTime :', trim(STR1) - endif - else - call ESMF_TimeSet(traj%obsfile_start_time, STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_begin provided: ', trim(STR1) - end if - end if - - call ESMF_ConfigGetAttribute(config, value=STR1, default="", & - label=trim(string) // 'obs_file_end:', _RC) - if (trim(STR1)=='') then - call ESMF_TimeIntervalSet(obs_time_span, d=14, _RC) - traj%obsfile_end_time = traj%obsfile_start_time + obs_time_span - call ESMF_TimeGet(traj%obsfile_end_time, timestring=STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_end missing, default = begin+14D:', trim(STR1) - endif - else - call ESMF_TimeSet(traj%obsfile_end_time, STR1, _RC) - if (mapl_am_I_root()) then - write(6,105) 'obs_file_end provided:', trim(STR1) - end if - end if - - call ESMF_ConfigGetAttribute(config, value=STR1, default="", & - label=trim(string) // 'obs_file_interval:', _RC) - _ASSERT(STR1/='', 'fatal error: obs_file_interval not provided in RC file') - if (mapl_am_I_root()) write(6,105) 'obs_file_interval:', trim(STR1) - if (mapl_am_I_root()) write(6,106) 'Epoch (second) :', second - - i= index( trim(STR1), ' ' ) - if (i>0) then - symd=STR1(1:i-1) - shms=STR1(i+1:) - else - symd='' - shms=trim(STR1) - endif - call convert_twostring_2_esmfinterval (symd, shms, traj%obsfile_interval, _RC) - traj%active = .true. - - - ! __ s1. overall print - call ESMF_ConfigGetDim(config, nline, col, label=trim(string)//'obs_files:', rc=rc) - _ASSERT(rc==0 .AND. nline > 0, 'obs_files not found') - !! write(6,*) 'nline, col', nline, col - allocate(ncol(1:nline)) - - call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC ) - do i = 1, nline - call ESMF_ConfigNextLine(config, _RC) - ncol(i) = ESMF_ConfigGetLen(config, _RC) - !!write(6,*) 'line', i, 'ncol(i)', ncol(i) - enddo - - - - ! __ s2. find nobs && distinguish design with vs wo '------' - nobs=0 - call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) - do i=1, nline - call ESMF_ConfigNextLine( config, tableEnd=tend, _RC) - call ESMF_ConfigGetAttribute( config, STR1, _RC) - if ( index(trim(STR1), '-----') > 0 ) nobs=nobs+1 - enddo - - ! __ s3. retrieve template and geoval, set metadata file_handle - lgr => logging%get_logger('HISTORY.sampler') - if ( nobs == 0 ) then - ! - ! treatment-1: - ! - _FAIL('this setting in HISTORY.rc obs_files: is not supported, stop') - traj%nobs_type = nline ! here .rc format cannot have empty spaces - allocate (traj%obs(nline)) - call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) - do i=1, nline - call ESMF_ConfigNextLine( config, tableEnd=tend, _RC) - call ESMF_ConfigGetAttribute( config, traj%obs(i)%input_template, _RC) - traj%obs(i)%export_all_geoval = .true. - enddo - else - ! - !-- selectively output geovals - ! treatment-2: - ! - traj%nobs_type = nobs - allocate (traj%obs(nobs)) - ! - nobs=0 ! reuse counter - head=1 - jvar=0 - - ! - ! count '------' in history.rc as special markers for ngeoval - ! - call ESMF_ConfigFindLabel(config, trim(string)//'obs_files:', _RC) - do i=1, nline - call ESMF_ConfigNextLine(config, tableEnd=tend, _RC) - M = ncol(i) - _ASSERT(M>=1, '# of columns should be >= 1') - allocate (word(M)) - count=0 - do col=1, M - call ESMF_ConfigGetAttribute(config, word(col), _RC) - if (trim(word(col))/=',') then - count=count+1 - end if - enddo - if (count ==1 .or. count==2) then - ! 1-item case: file template or one-var - ! 2-item : var1 , 'root' case - STR1=trim(word(1)) - else - ! 3-item : var1 , 'root', var1_alias case - STR1=trim(word(M)) - end if - deallocate(word) - if ( index(trim(STR1), '-----') == 0 ) then - if (head==1 .AND. trim(STR1)/='') then - nobs=nobs+1 - traj%obs(nobs)%input_template = trim(STR1) - traj%obs(nobs)%export_all_geoval = .false. - head=0 - else - if (trim(STR1)/='') then - jvar=jvar+1 - traj%obs(nobs)%geoval_name(jvar) = trim(STR1) - end if - end if - else - traj%obs(nobs)%ngeoval=jvar - head=1 - jvar=0 - endif - enddo - end if - - do k=1, traj%nobs_type - allocate (traj%obs(k)%metadata) - if (mapl_am_i_root()) then - allocate (traj%obs(k)%file_handle) - end if - end do - - call lgr%debug('%a %i8', 'nobs_type=', traj%nobs_type) - do i=1, traj%nobs_type - call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & - trim(traj%obs(i)%input_template)) - j=index(traj%obs(i)%input_template , '%') - k=index(traj%obs(i)%input_template , '/', back=.true.) - _ASSERT(j>0, '% is not found, template is wrong') - traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) - end do - - _RETURN(_SUCCESS) - - -105 format (1x,a,2x,a) -106 format (1x,a,2x,i8) - end procedure HistoryTrajectory_from_config - - - ! - !-- integrate both initialize and reinitialize - ! - module procedure initialize_ - integer :: status - type(ESMF_Grid) :: grid - type(variable) :: v - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_Time) :: currTime - integer :: k - - if (.not. present(reinitialize)) then - if(present(bundle)) this%bundle=bundle - if(present(items)) this%items=items - if(present(timeInfo)) this%time_info=timeInfo - if (present(vdata)) then - this%vdata=vdata - else - this%vdata=VerticalData(_RC) - end if - else - if (reinitialize) then - do k=1, this%nobs_type - allocate (this%obs(k)%metadata) - if (mapl_am_i_root()) then - allocate (this%obs(k)%file_handle) - end if - end do - end if - end if - - do k=1, this%nobs_type - call this%vdata%append_vertical_metadata(this%obs(k)%metadata,this%bundle,_RC) - end do - this%do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) - if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%bundle,_RC) - - call ESMF_ClockGet (this%clock, CurrTime=currTime, _RC) - call get_obsfile_Tbracket_from_epoch(currTime, & - this%obsfile_start_time, this%obsfile_end_time, & - this%obsfile_interval, this%epoch_frequency, & - this%obsfile_Ts_index, this%obsfile_Te_index, _RC) - if (this%obsfile_Te_index < 0) then - if (mapl_am_I_root()) then - write(6,*) "model start time is earlier than obsfile_start_time" - write(6,*) "solution: adjust obsfile_start_time and Epoch in rc file" - end if - _FAIL("obs file not found at init time") - endif - call this%create_grid(_RC) - - call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - this%regridder = LocStreamRegridder(grid,this%LS_ds,_RC) - this%output_bundle = this%create_new_bundle(_RC) - this%acc_bundle = this%create_new_bundle(_RC) - - - do k=1, this%nobs_type - call this%obs(k)%metadata%add_dimension(this%index_name_x, this%obs(k)%nobs_epoch) - if (this%time_info%integer_time) then - v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) - else - v = Variable(type=PFIO_REAL64,dimensions=this%index_name_x) - end if - call v%add_attribute('units', this%datetime_units) - call v%add_attribute('long_name', 'dateTime') - call this%obs(k)%metadata%add_variable(this%var_name_time,v) - - v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) - call v%add_attribute('units', '1') - call v%add_attribute('long_name', 'Location index in corresponding IODA file') - call this%obs(k)%metadata%add_variable(this%location_index_name,v) - - v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) - call v%add_attribute('units','degrees_east') - call v%add_attribute('long_name','longitude') - call this%obs(k)%metadata%add_variable(this%var_name_lon,v) - - v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) - call v%add_attribute('units','degrees_north') - call v%add_attribute('long_name','latitude') - call this%obs(k)%metadata%add_variable(this%var_name_lat,v) - end do - - ! push varible names down to each obs(k); see create_metadata_variable - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call this%create_variable(item%xname,_RC) - else if (item%itemType == ItemTypeVector) then - call this%create_variable(item%xname,_RC) - call this%create_variable(item%yname,_RC) - end if - call iter%next() - enddo - - _RETURN(_SUCCESS) - - end procedure initialize_ - - - - module procedure create_metadata_variable - type(ESMF_Field) :: field - type(variable) :: v - logical :: is_present - integer :: field_rank, status - character(len=ESMF_MAXSTR) :: var_name,long_name,units,vdims - integer :: k, ig - - call ESMF_FieldBundleGet(this%bundle,vname,field=field,_RC) - call ESMF_FieldGet(field,name=var_name,rank=field_rank,_RC) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet (FIELD, NAME="LONG_NAME",VALUE=long_name, _RC) - else - long_name = var_name - endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet (FIELD, NAME="UNITS",VALUE=units, _RC) - else - units = 'unknown' - endif - if (field_rank==2) then - vdims = this%index_name_x - else if (field_rank==3) then - vdims = trim(this%index_name_x)//",lev" - end if - v = variable(type=PFIO_REAL32,dimensions=trim(vdims)) - call v%add_attribute('units',trim(units)) - call v%add_attribute('long_name',trim(long_name)) - call v%add_attribute('missing_value',MAPL_UNDEF) - call v%add_attribute('_FillValue',MAPL_UNDEF) - call v%add_attribute('valid_range',(/-MAPL_UNDEF,MAPL_UNDEF/)) - - do k = 1, this%nobs_type - do ig = 1, this%obs(k)%ngeoval - if (trim(var_name) == trim(this%obs(k)%geoval_name(ig))) then - call this%obs(k)%metadata%add_variable(trim(var_name),v,_RC) - endif - enddo - enddo - - _RETURN(_SUCCESS) - end procedure create_metadata_variable - - - module procedure create_new_bundle - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_Field) :: src_field,dst_field - integer :: rank,lb(1),ub(1) - integer :: status - - new_bundle = ESMF_FieldBundleCreate(_RC) - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) - call ESMF_FieldGet(src_field,rank=rank,_RC) - if (rank==2) then - dst_field = ESMF_FieldCreate(this%LS_ds,name=trim(item%xname), & - typekind=ESMF_TYPEKIND_R4,_RC) - else if (rank==3) then - call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - if (this%vdata%lm/=(ub(1)-lb(1)+1)) then - lb(1)=1 - ub(1)=this%vdata%lm - end if - dst_field = ESMF_FieldCreate(this%LS_ds,name=trim(item%xname), & - typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - end if - call MAPL_FieldBundleAdd(new_bundle,dst_field,_RC) - else if (item%itemType == ItemTypeVector) then -!! _FAIL("ItemTypeVector not yet supported") - end if - call iter%next() - enddo - _RETURN(_SUCCESS) - - end procedure create_new_bundle - - - module procedure create_file_handle - use pflogger, only : Logger, logging - integer :: status - integer :: k - character(len=ESMF_MAXSTR) :: filename - type(Logger), pointer :: lgr - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - rc=0 - return - endif - - lgr => logging%get_logger('HISTORY.sampler') - do k=1, this%nobs_type - call this%obs(k)%metadata%modify_dimension(this%index_name_x, this%obs(k)%nobs_epoch) - enddo - if (mapl_am_I_root()) then - do k=1, this%nobs_type - if (this%obs(k)%nobs_epoch > 0) then - filename=trim(this%obs(k)%name)//trim(filename_suffix) - call lgr%debug('%a %a', & - "Sampling to new file : ",trim(filename)) - call this%obs(k)%file_handle%create(trim(filename),_RC) - call this%obs(k)%file_handle%write(this%obs(k)%metadata,_RC) - end if - enddo - end if - - _RETURN(_SUCCESS) - end procedure create_file_handle - - - module procedure close_file_handle - integer :: status - integer :: k - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - rc=0 - return - endif - - if (mapl_am_I_root()) then - do k=1, this%nobs_type - if (this%obs(k)%nobs_epoch > 0) then - call this%obs(k)%file_handle%close(_RC) - end if - end do - end if - _RETURN(_SUCCESS) - end procedure close_file_handle - - - module procedure create_grid - use pflogger, only: Logger, logging - character(len=ESMF_MAXSTR) :: filename - integer(ESMF_KIND_I4) :: num_times - integer :: len - integer :: len_full - integer :: status - type(Logger), pointer :: lgr - - character(len=ESMF_MAXSTR) :: grp_name - character(len=ESMF_MAXSTR) :: timeunits_file - character :: new_char(ESMF_MAXSTR) - - real(kind=REAL64), allocatable :: lons_full(:), lats_full(:) - real(kind=REAL64), allocatable :: times_R8_full(:) - real(kind=REAL64) :: t_shift - integer, allocatable :: obstype_id_full(:) - integer, allocatable :: location_index_ioda_full(:) - integer, allocatable :: IA_full(:) - - real(ESMF_KIND_R8), pointer :: ptAT(:) - type(ESMF_routehandle) :: RH - type(ESMF_Time) :: timeset(2) - type(ESMF_Time) :: current_time - type(ESMF_Time) :: time0 - type(ESMF_TimeInterval) :: dt - type(ESMF_Grid) :: grid - - type(ESMF_VM) :: vm - integer :: mypet, petcount - - integer :: i, j, k, L, ii, jj - integer :: fid_s, fid_e - integer(kind=ESMF_KIND_I8) :: j0, j1 - integer(kind=ESMF_KIND_I8) :: jt1, jt2 - integer(kind=ESMF_KIND_I8) :: nstart, nend - real(kind=ESMF_KIND_R8) :: jx0, jx1 - integer :: nx, nx_sum - integer :: n0 - integer :: arr(1) - integer :: sec - integer, allocatable :: ix(:) ! counter for each obs(k)%nobs_epoch - integer :: nx2 - logical :: EX ! file - logical :: zero_obs - -!! this%datetime_units = "seconds since 1970-01-01 00:00:00" - lgr => logging%get_logger('HISTORY.sampler') - - call ESMF_VMGetGlobal(vm,_RC) - call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) - - if (this%index_name_x == '') then - ! - !-- non IODA case / non netCDF - ! - _FAIL('non-IODA format is not implemented here') - end if - - ! - !-- IODA case - ! - i=index(this%var_name_lon_full, '/') - if (i==0) then - grp_name = '' - call lgr%debug('%a', 'grp_name not found') - else - grp_name = this%var_name_lon_full(1:i-1) - end if - this%var_name_lon = this%var_name_lon_full(i+1:) - i=index(this%var_name_lat_full, '/') - this%var_name_lat = this%var_name_lat_full(i+1:) - i=index(this%var_name_time_full, '/') - this%var_name_time= this%var_name_time_full(i+1:) - this%location_index_name = 'location_index_in_iodafile' - - call lgr%debug('%a', 'grp_name,this%index_name_x,this%var_name_lon,this%var_name_lat,this%var_name_time') - call lgr%debug('%a %a %a %a %a', & - trim(grp_name),trim(this%index_name_x),trim(this%var_name_lon),& - trim(this%var_name_lat),trim(this%var_name_time)) - - L=0 - fid_s=this%obsfile_Ts_index - fid_e=this%obsfile_Te_index - - call lgr%debug('%a %i10 %i10', & - 'fid_s, fid_e', fid_s, fid_e) - - arr(1)=0 ! len_full - if (mapl_am_I_root()) then - len = 0 - do k=1, this%nobs_type - j = max (fid_s, L) - do while (j<=fid_e) - filename = get_filename_from_template_use_index( & - this%obsfile_start_time, this%obsfile_interval, & - j, this%obs(k)%input_template, EX, _RC) - if (EX) then - call lgr%debug('%a %i10', 'exist: filename fid j :', j) - call lgr%debug('%a %a', 'exist: true filename :', trim(filename)) - call get_ncfile_dimension(filename, tdim=num_times, key_time=this%index_name_x, _RC) - len = len + num_times - else - call lgr%debug('%a %i10', 'non-exist: filename fid j :', j) - call lgr%debug('%a %a', 'non-exist: missing filename:', trim(filename)) - end if - j=j+1 - enddo - enddo - arr(1)=len - - if (len>0) then - allocate(lons_full(len),lats_full(len),_STAT) - allocate(times_R8_full(len),_STAT) - allocate(obstype_id_full(len),_STAT) - allocate(location_index_ioda_full(len),_STAT) - allocate(IA_full(len),_STAT) - call lgr%debug('%a %i12', 'nobs from input file:', len) - len = 0 - ii = 0 - do k=1, this%nobs_type - j = max (fid_s, L) - do while (j<=fid_e) - filename = get_filename_from_template_use_index( & - this%obsfile_start_time, this%obsfile_interval, & - j, this%obs(k)%input_template, EX, _RC) - if (EX) then - ii = ii + 1 - call get_ncfile_dimension(trim(filename), tdim=num_times, key_time=this%index_name_x, _RC) - call get_v1d_netcdf_R8 (filename, this%var_name_lon, lons_full(len+1:), num_times, group_name=grp_name) - call get_v1d_netcdf_R8 (filename, this%var_name_lat, lats_full(len+1:), num_times, group_name=grp_name) - call get_v1d_netcdf_R8 (filename, this%var_name_time, times_R8_full(len+1:), num_times, group_name=grp_name) - call get_attribute_from_group (filename, grp_name, this%var_name_time, "units", timeunits_file) - if (ii == 1) then - this%datetime_units = trim(timeunits_file) - call lgr%debug('%a %a', 'datetime_units from 1st file:', trim(timeunits_file)) - end if - call diff_two_timeunits (this%datetime_units, timeunits_file, t_shift, _RC) - times_R8_full(len+1:len+num_times) = times_R8_full(len+1:len+num_times) + t_shift - obstype_id_full(len+1:len+num_times) = k - do jj = 1, num_times - location_index_ioda_full(len+jj) = jj - end do - len = len + num_times - end if - j=j+1 - enddo - enddo - end if - end if - - - call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & - count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) - if (nx_sum == 0) then - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - allocate(this%location_index_ioda(0),_STAT) - this%epoch_index(1:2) = 0 - this%nobs_epoch = 0 - this%nobs_epoch_sum = 0 - ! - ! empty shell to keep regridding and destroy_RH_LS to work - ! - this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) - this%LS_rt = this%locstream_factory%create_locstream(_RC) - call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) - this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) - call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) - this%obsTime= -1.d0 - rc = 0 - return - end if - call MAPL_CommsBcast(vm, this%datetime_units, N=ESMF_MAXSTR, ROOT=MAPL_Root, _RC) - - - - if (mapl_am_I_root()) then - call sort_index (times_R8_full, IA_full, _RC) - call apply_order_index (location_index_ioda_full, IA_full, _RC) - ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time - call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) - call ESMF_ClockGet(this%clock,currTime=current_time,_RC) - timeset(1) = current_time - timeset(2) = current_time + this%epoch_frequency - call time_esmf_2_nc_int (timeset(1), this%datetime_units, j0, _RC) - sec = hms_2_s(this%Epoch) - j1 = j0 + int(sec, kind=ESMF_KIND_I8) - jx0 = real ( j0, kind=ESMF_KIND_R8) - jx1 = real ( j1, kind=ESMF_KIND_R8) - - nstart=1; nend=size(times_R8_full) - call bisect( times_R8_full, jx0, jt1, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) - call bisect( times_R8_full, jx1, jt2, n_LB=int(nstart, ESMF_KIND_I8), n_UB=int(nend, ESMF_KIND_I8), rc=rc) - call lgr%debug ('%a %i20 %i20', 'nstart, nend', nstart, nend) - call lgr%debug ('%a %f20.1 %f20.1', 'j0[currT] j1[T+Epoch] w.r.t. timeunit ', jx0, jx1) - call lgr%debug ('%a %f20.1 %f20.1', 'x0[times(1)] xn[times(N)] w.r.t. timeunit ', & - times_R8_full(1), times_R8_full(nend)) - call lgr%debug ('%a %i20 %i20', 'jt1, jt2 [final intercepted position]', jt1, jt2) - - -! if (jt1==jt2) then -! _FAIL('Epoch Time is too small, empty grid is generated, increase Epoch') -! endif - - !-- shift the zero item to index 1 - zero_obs = .false. - if (jt1/=jt2) then - zero_obs = .false. - if (jt1==0) jt1=1 - else - ! at most one obs point exist, set it .true. - zero_obs = .true. - !! if (jt1==0) jt1=1 - end if - - ! - !-- exclude the out-of-range case - ! - if ( zero_obs ) then - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - allocate(this%location_index_ioda(0),_STAT) - this%epoch_index(1:2)=0 - this%nobs_epoch = 0 - nx=0 - arr(1)=nx - else - !! doulbe check - ! (x1, x2] design in bisect - this%epoch_index(1)= jt1 + 1 - -!! ! (x1, x2] design in bisect -!! if (jt1==0) then -!! this%epoch_index(1)= 1 -!! else -!! this%epoch_index(1)= jt1 -!! endif - _ASSERT(jt2<=len, 'bisect index for this%epoch_index(2) failed') - if (jt2==0) then - this%epoch_index(2)= 1 - else - this%epoch_index(2)= jt2 - endif - - nx= this%epoch_index(2) - this%epoch_index(1) + 1 - this%nobs_epoch = nx - - - allocate(this%lons(nx),this%lats(nx),_STAT) - allocate(this%times_R8(nx),_STAT) - allocate(this%obstype_id(nx),_STAT) - allocate(this%location_index_ioda(nx),_STAT) - - j=this%epoch_index(1) - do i=1, nx - this%lons(i) = lons_full(j) - this%lats(i) = lats_full(j) - this%times_R8(i) = times_R8_full(j) - this%obstype_id(i) = obstype_id_full(j) - this%location_index_ioda(i) = location_index_ioda_full(j) - j=j+1 - enddo - arr(1)=nx - - do k=1, this%nobs_type - this%obs(k)%nobs_epoch = 0 - enddo - do j = this%epoch_index(1), this%epoch_index(2) - k = obstype_id_full(j) - this%obs(k)%nobs_epoch = this%obs(k)%nobs_epoch + 1 - enddo - - do k=1, this%nobs_type - nx2 = this%obs(k)%nobs_epoch - allocate (this%obs(k)%lons(nx2)) - allocate (this%obs(k)%lats(nx2)) - allocate (this%obs(k)%times_R8(nx2)) - allocate (this%obs(k)%location_index_ioda(nx2)) - enddo - - allocate(ix(this%nobs_type)) - ix(:)=0 - j=this%epoch_index(1) - do i=1, nx - k = obstype_id_full(j) - ix(k) = ix(k) + 1 - this%obs(k)%lons(ix(k)) = lons_full(j) - this%obs(k)%lats(ix(k)) = lats_full(j) - this%obs(k)%times_R8(ix(k)) = times_R8_full(j) - this%obs(k)%location_index_ioda(ix(k)) = location_index_ioda_full(j) - !if (mod(k,10**8)==1) then - ! write(6,*) 'this%obs(k)%times_R8(ix(k))', this%obs(k)%times_R8(ix(k)) - !endif - j=j+1 - enddo - deallocate(ix) - deallocate(lons_full, lats_full, times_R8_full, obstype_id_full, location_index_ioda_full) - - call lgr%debug('%a %i12 %i12 %i12', & - 'epoch_index(1:2), nx', this%epoch_index(1), & - this%epoch_index(2), this%nobs_epoch) - do k=1, this%nobs_type - call lgr%debug('%a %i4 %a %i12', & - 'obs(', k, ')%nobs_epoch', this%obs(k)%nobs_epoch ) - enddo - end if - else - allocate(this%lons(0),this%lats(0),_STAT) - allocate(this%times_R8(0),_STAT) - allocate(this%obstype_id(0),_STAT) - allocate(this%location_index_ioda(0),_STAT) - this%epoch_index(1:2)=0 - this%nobs_epoch = 0 - nx=0 - arr(1)=nx - endif - - call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & - count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) - this%nobs_epoch_sum = nx_sum - call lgr%debug('%a %i20', 'nobservation points=', nx_sum) - - - this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) - this%LS_rt = this%locstream_factory%create_locstream(_RC) - call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) - - this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) - this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) - - call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) - call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) - if (mypet == 0) then - ptAT(:) = this%times_R8(:) - end if - this%obsTime= -1.d0 - - call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) - call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) - - !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) - - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) - ! defer destroy fieldB at regen_grid step - ! - - - _RETURN(_SUCCESS) - end procedure create_grid - - - - module procedure append_file - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_RouteHandle) :: RH - - type(ESMF_Field) :: src_field, dst_field - type(ESMF_Field) :: acc_field - type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt - real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) - real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) - - integer :: is, ie, nx - integer :: lm - integer :: rank - integer :: status - integer :: j, k, ig - integer, allocatable :: ix(:) - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - rc=0 - return - endif - - is=1 - do k = 1, this%nobs_type - !-- limit nx < 2**32 (integer*4) - nx=this%obs(k)%nobs_epoch - if (nx >0) then - if (mapl_am_i_root()) then - call this%obs(k)%file_handle%put_var(this%var_name_time, real(this%obs(k)%times_R8), & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%var_name_lon, this%obs(k)%lons, & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & - start=[is], count=[nx], _RC) - end if - end if - enddo - - ! get RH from 2d field - src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) - dst_field = ESMF_FieldCreate(this%LS_rt,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) - call ESMF_FieldRedistStore(src_field,dst_field,RH,_RC) - call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) - - ! redist and put_var - lm = this%vdata%lm - acc_field_2d_rt = ESMF_FieldCreate (this%LS_rt, name='field_2d_rt', typekind=ESMF_TYPEKIND_R4, _RC) - acc_field_3d_rt = ESMF_FieldCreate (this%LS_rt, name='field_3d_rt', typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - !!write(6, '(2x,a,2x,a)') 'item%xname', trim(item%xname) - - if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) - call ESMF_FieldGet(acc_field,rank=rank,_RC) - if (rank==1) then - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC) - call ESMF_FieldGet( acc_field_2d_rt, localDE=0, farrayPtr=p_acc_rt_2d, _RC) - call ESMF_FieldRedist( acc_field, acc_field_2d_rt, RH, _RC) - if (mapl_am_i_root()) then - ! - !-- pack fields to obs(k)%p2d and put_var - ! - is=1 - ie=this%epoch_index(2)-this%epoch_index(1)+1 - do k=1, this%nobs_type - nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p2d(nx)) - enddo - - allocate(ix(this%nobs_type)) - ix(:)=0 - do j=is, ie - k = this%obstype_id(j) - ix(k) = ix(k) + 1 - this%obs(k)%p2d(ix(k)) = p_acc_rt_2d(j) - enddo - - do k=1, this%nobs_type - if (ix(k) /= this%obs(k)%nobs_epoch) then - print*, 'obs_', k, ' : ix(k) /= this%obs(k)%nobs_epoch' - print*, 'obs_', k, ' : this%obs(k)%nobs_epoch, ix(k) =', this%obs(k)%nobs_epoch, ix(k) - _FAIL('test ix(k) failed') - endif - enddo - deallocate(ix) - do k=1, this%nobs_type - is = 1 - nx = this%obs(k)%nobs_epoch - if (nx>0) then - do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then - call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & - start=[is],count=[nx]) - end if - enddo - endif - enddo - do k=1, this%nobs_type - deallocate (this%obs(k)%p2d) - enddo - end if - else if (rank==2) then - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) - call ESMF_FieldGet( acc_field_3d_rt, localDE=0, farrayPtr=p_acc_rt_3d, _RC) - - dst_field=ESMF_FieldCreate(this%LS_rt,typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) - call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) - - p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) - call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) - p_acc_rt_3d=reshape(p_dst, shape(p_acc_rt_3d), order=[2,1]) - - call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) - call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - - if (mapl_am_i_root()) then - ! - !-- pack fields to obs(k)%p3d and put_var - ! - is=1 - ie=this%epoch_index(2)-this%epoch_index(1)+1 - do k=1, this%nobs_type - nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2))) - enddo - allocate(ix(this%nobs_type)) - ix(:)=0 - do j=is, ie - k = this%obstype_id(j) - ix(k) = ix(k) + 1 - this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) - enddo - deallocate(ix) - do k=1, this%nobs_type - is = 1 - nx = this%obs(k)%nobs_epoch - if (nx>0) then - do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then - call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & - start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - end if - end do - endif - enddo - !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) - !!write(6,*) 'here in append_file: put_var 3d' - !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& - !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - !! - do k=1, this%nobs_type - deallocate (this%obs(k)%p3d) - enddo - end if - endif - else if (item%itemType == ItemTypeVector) then - _FAIL("ItemTypeVector not yet supported") - end if - call iter%next() - enddo - call ESMF_FieldDestroy(acc_field_2d_rt, noGarbage=.true., _RC) - call ESMF_FieldDestroy(acc_field_3d_rt, noGarbage=.true., _RC) - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - - _RETURN(_SUCCESS) - end procedure append_file - - - - - module procedure regrid_accumulate_on_xsubset - integer :: x_subset(2) - type(ESMF_Time) :: timeset(2) - type(ESMF_Time) :: current_time - type(ESMF_TimeInterval) :: dur - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_Field) :: src_field,dst_field,acc_field - integer :: rank - real(kind=REAL32), allocatable :: p_new_lev(:,:,:) - real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) - real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) - real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - type(ESMF_VM) :: vm - integer :: mypet, petcount - integer :: is, ie, nx_sum - integer :: status - integer :: arr(1) - - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - rc=0 - return - endif - - call ESMF_ClockGet(this%clock,currTime=current_time,_RC) - call ESMF_ClockGet(this%clock,timeStep=dur, _RC ) - timeset(1) = current_time - dur - timeset(2) = current_time - call this%get_x_subset(timeset, x_subset, _RC) - is=x_subset(1) - ie=x_subset(2) - !! write(6,'(2x,a,4i10)') 'in regrid_accumulate is, ie=', is, ie - - - ! - ! __ I designed a method to return from regridding if no valid points exist - ! in reality for 29 ioda platforms and dt > 20 sec, we donot need this - ! - !!arr(1)=1 - !!if (.NOT. (is > 0 .AND. is <= ie )) arr(1)=0 - !!call ESMF_VMGetGlobal(vm,_RC) - !!call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) - !!call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & - !! count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) - !!if ( nx_sum == 0 ) then - !! write(6, '(2x,a,2x,3i10)') 'invalid points, mypet, is, ie =', mypet, is, ie - !! ! no valid points to regrid - !! _RETURN(ESMF_SUCCESS) - !!else - !! write(6, '(2x,a,2x,3i10)') ' valid points, mypet, is, ie =', mypet, is, ie - !!end if - - - if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%setup_eta_to_pressure(_RC) - endif - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%bundle,trim(item%xname),field=src_field,_RC) - call ESMF_FieldBundleGet(this%output_bundle,trim(item%xname),field=dst_field,_RC) - call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) - call ESMF_FieldGet(src_field,rank=rank,_RC) - if (rank==2) then - call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) - call ESMF_FieldGet(acc_field,farrayptr=p_acc_2d,_RC) - - !! print*, 'size(src,dst,acc)', size(p_src_2d), size(p_dst_2d), size(p_acc_2d) - call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) - if (is > 0 .AND. is <= ie ) then - p_acc_2d(is:ie) = p_dst_2d(is:ie) - endif - - !!if (is>0) write(6,'(a)') 'regrid_accu: p_dst_2d' - !!if (is>0) write(6,'(10f7.1)') p_dst_2d - - else if (rank==3) then - call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) - call ESMF_FieldGet(acc_field,farrayptr=p_acc_3d,_RC) - if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - allocate(p_new_lev(size(p_src_3d,1),size(p_src_3d,2),this%vdata%lm),_STAT) - call this%vdata%regrid_eta_to_pressure(p_src_3d,p_new_lev,_RC) - call this%regridder%regrid(p_new_lev,p_dst_3d,_RC) - if (is > 0 .AND. is <= ie ) then - p_acc_3d(is:ie,:) = p_dst_3d(is:ie,:) - end if - else - call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) - if (is > 0 .AND. is <= ie ) then - p_acc_3d(is:ie,:) = p_dst_3d(is:ie,:) - end if - end if - end if - else if (item%itemType == ItemTypeVector) then - _FAIL("ItemTypeVector not yet supported") - end if - call iter%next() - enddo - - _RETURN(ESMF_SUCCESS) - - end procedure regrid_accumulate_on_xsubset - - - module procedure destroy_rh_regen_LS - integer :: status - integer :: numVars, i, k - character(len=ESMF_MAXSTR), allocatable :: names(:) - type(ESMF_Field) :: field - type(ESMF_Time) :: currTime - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - call ESMF_FieldDestroy(this%fieldB,nogarbage=.true.,_RC) - call this%locstream_factory%destroy_locstream(this%LS_rt, _RC) - call this%locstream_factory%destroy_locstream(this%LS_ds, _RC) - call this%regridder%destroy(_RC) - deallocate (this%lons, this%lats, & - this%times_R8, this%obstype_id, this%location_index_ioda) - - do k=1, this%nobs_type - deallocate (this%obs(k)%metadata) - if (mapl_am_i_root()) then - deallocate (this%obs(k)%file_handle) - end if - end do - - if (mapl_am_i_root()) then - do k=1, this%nobs_type - if (allocated (this%obs(k)%lons)) then - deallocate (this%obs(k)%lons) - end if - if (allocated (this%obs(k)%lats)) then - deallocate (this%obs(k)%lats) - end if - if (allocated (this%obs(k)%times_R8)) then - deallocate (this%obs(k)%times_R8) - end if - if (allocated (this%obs(k)%location_index_ioda)) then - deallocate (this%obs(k)%location_index_ioda) - end if - if (allocated(this%obs(k)%p2d)) then - deallocate (this%obs(k)%p2d) - endif - if (allocated(this%obs(k)%p3d)) then - deallocate (this%obs(k)%p3d) - endif - end do - end if - - call ESMF_FieldBundleGet(this%acc_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) - call ESMF_FieldBundleGet(this%acc_bundle,fieldNameList=names,_RC) - do i=1,numVars - call ESMF_FieldBundleGet(this%acc_bundle,trim(names(i)),field=field,_RC) - call ESMF_FieldDestroy(field,noGarbage=.true., _RC) - enddo - call ESMF_FieldBundleDestroy(this%acc_bundle,noGarbage=.true.,_RC) - - call ESMF_FieldBundleGet(this%output_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) - call ESMF_FieldBundleGet(this%output_bundle,fieldNameList=names,_RC) - do i=1,numVars - call ESMF_FieldBundleGet(this%output_bundle,trim(names(i)),field=field,_RC) - call ESMF_FieldDestroy(field,noGarbage=.true., _RC) - enddo - call ESMF_FieldBundleDestroy(this%output_bundle,noGarbage=.true.,_RC) - - - call ESMF_ClockGet ( this%clock, CurrTime=currTime, _RC ) - if (currTime > this%obsfile_end_time) then - this%active = .false. - _RETURN(ESMF_SUCCESS) - end if - - this%epoch_index(1:2)=0 - - call this%initialize(reinitialize=.true., _RC) - - _RETURN(ESMF_SUCCESS) - - end procedure destroy_rh_regen_LS - - - module procedure get_x_subset - type (ESMF_Time) :: T1, T2 - real (ESMF_KIND_R8) :: rT1, rT2 - - integer(ESMF_KIND_I8) :: i1, i2 - integer(ESMF_KIND_I8) :: index1, index2, lb, ub - integer :: jlo, jhi - integer :: status - - T1= interval(1) - T2= interval(2) - call time_esmf_2_nc_int (T1, this%datetime_units, i1, _RC) - call time_esmf_2_nc_int (T2, this%datetime_units, i2, _RC) - rT1=real(i1, kind=ESMF_KIND_R8) - rT2=real(i2, kind=ESMF_KIND_R8) - jlo = 1 - !! - !! I choose UB = N+1 not N, because my sub. bisect find n: Y(n)0) then - do i=1, nskip - read(unit, *) - end do - end if - read(unit, '(a100)', IOSTAT=ios) line - call count_substring(line, ',', ncount, _RC) - con1= (ncount>=2 .AND. ncount<=4).OR.(ncount==0) - _ASSERT(con1, 'string sequence in Aeronet file not supported') - if (ncount==0) then - seq='AFFFA' - elseif (ncount==2) then - seq='AFF' - elseif (ncount==3) then - seq='AFFF' - elseif (ncount==4) then - CH1=line(1:1) - con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') - con2= CH1>='0'.AND.CH1<='9' - if (con1) then - seq='AIFFF' - else - if (con2) then - seq='IAFFF' - else - _ASSERT(.false., 'string sequence in Aeronet file not supported') - end if - end if - end if - - rewind(unit) - if (nskip>0) then - do i=1, nskip - read(unit, *) - end do - end if - ios=0 - do while (ios==0) - read(unit, '(a100)', IOSTAT=ios) line - if (ios==0) nstation=nstation+1 - end do - sampler%nstation=nstation - allocate(sampler%station_id(nstation)) - allocate(sampler%station_name(nstation)) - allocate(sampler%station_fullname(nstation)) - allocate(sampler%lons(nstation)) - allocate(sampler%lats(nstation)) - allocate(sampler%elevs(nstation)) - - rewind(unit) - if (nskip>0) then - do i=1, nskip - read(unit, *) - end do - end if - do i=1, nstation - if(seq=='IAFFF') then - read(unit, *) & - sampler%station_id(i), & - sampler%station_name(i), & - sampler%lons(i), & - sampler%lats(i) - elseif(seq=='AIFFF') then - read(unit, *) & - sampler%station_name(i), & - sampler%station_id(i), & - sampler%lons(i), & - sampler%lats(i) - elseif(trim(seq)=='AFF' .OR. trim(seq)=='AFFF') then - !!write(6,*) 'i=', i - line='' - read(unit, '(a100)') line - !!write(6,*) 'line=', trim(line) - call CSV_read_line_with_CH_I_R(line, & - sampler%station_name(i), & - sampler%lons(i), & - sampler%lats(i), _RC) - sampler%station_id(i)=i - elseif(trim(seq)=='AFFFA') then - ! Ex: 'ZI000067991 -22.2170 30.0000 457.0 BEITBRIDGE 67991' - read(unit, *) & - sampler%station_name(i), & - sampler%lons(i), & - sampler%lats(i) - - sampler%station_id(i)=i - backspace(unit) - read(unit, '(a100)', IOSTAT=ios) line - j=index(line, '.', BACK=.true.) - line2=line(j+1:) - k=len(line2) - line='' - do j=1, k - CH1=line2(j:j) - con1= (CH1>='a'.AND.CH1<='z').OR.(CH1>='A'.AND.CH1<='Z') - if (con1) exit - enddo - read(line2(j:k), '(a100)') line - line2=trim(line) - k=len(line2) - line='' - do j=1, k - CH1=line2(j:j) - con1= (CH1>='0' .AND. CH1<='9') - if (con1) exit - enddo - if (j>k) j=k - sampler%station_fullname(i) = trim(line2(1:j-1)) - end if - end do - close(unit) - lgr => logging%get_logger('HISTORY.sampler') - call lgr%debug('%a %i8', 'nstation=', nstation) - call lgr%debug('%a %a %a', 'sampler%station_name(1:2) : ', & - trim(sampler%station_name(1)), trim(sampler%station_name(2))) - call lgr%debug('%a %f8.2 %f8.2', 'sampler%lons(1:2) : ',& - sampler%lons(1),sampler%lons(2)) - call lgr%debug('%a %f8.2 %f8.2', 'sampler%lats(1:2) : ',& - sampler%lats(1),sampler%lats(2)) - - !__ 2. create LocStreamFactory, then esmf_ls including route_handle - ! - sampler%LSF = LocStreamFactory(sampler%lons, sampler%lats, _RC) - sampler%esmf_ls = sampler%LSF%create_locstream(_RC) - ! - ! init ofile - sampler%ofile='' - sampler%obs_written=0 - - _RETURN(_SUCCESS) - end function new_StationSampler_readfile - - - subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) - class(StationSampler), intent(inout) :: this - type(ESMF_FieldBundle), intent(in) :: bundle - type(TimeData), intent(inout) :: timeInfo - type(VerticalData), optional, intent(inout) :: vdata - integer, optional, intent(out) :: rc - - type(variable) :: v - type(ESMF_Grid) :: grid - type(ESMF_Field) :: field - integer :: fieldCount - integer :: field_rank - integer :: nstation - logical :: is_present - integer :: ub(ESMF_MAXDIM) - integer :: lb(ESMF_MAXDIM) - logical :: do_vertical_regrid - integer :: status - integer :: i - - character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) - character(len=ESMF_MAXSTR) :: var_name, long_name, units, vdims - - !__ 1. metadata add_dimension, - ! add_variable for time, latlon, station - ! - this%bundle = bundle - nstation = this%nstation - if (present(vdata)) then - this%vdata = vdata - else - this%vdata = VerticalData(_RC) - end if - call this%vdata%append_vertical_metadata(this%fmd,this%bundle,_RC) ! specify lev in fmd - do_vertical_regrid = (this%vdata%regrid_type /= VERTICAL_METHOD_NONE) - if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) then - call this%vdata%get_interpolating_variable(this%bundle,_RC) - endif - - call timeInfo%add_time_to_metadata(this%fmd,_RC) ! specify time in fmd - this%time_info = timeInfo - - call this%fmd%add_dimension('station_index',nstation) - - v = Variable(type=pFIO_REAL32, dimensions='station_index') - call v%add_attribute('long_name','longitude') - call v%add_attribute('unit','degree_east') - call this%fmd%add_variable('longitude',v) - - v = Variable(type=pFIO_REAL32, dimensions='station_index') - call v%add_attribute('long_name','latitude') - call v%add_attribute('unit','degree_north') - call this%fmd%add_variable('latitude',v) - - v = Variable(type=pFIO_INT32, dimensions='station_index') - call this%fmd%add_variable('station_id',v) - v = Variable(type=pFIO_STRING, dimensions='station_index') - call v%add_attribute('long_name','station name') - call this%fmd%add_variable('station_name',v) - - - !__ 2. filemetadata: extract field from bundle, add_variable - ! - call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount)) - call ESMF_FieldBundleGet(bundle, fieldNameList=fieldNameList, _RC) - do i=1, fieldCount - var_name=trim(fieldNameList(i)) - call ESMF_FieldBundleGet(bundle,var_name,field=field,_RC) - call ESMF_FieldGet(field,rank=field_rank,_RC) - call ESMF_AttributeGet(field,name="LONG_NAME",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet(field, NAME="LONG_NAME",VALUE=long_name, _RC) - else - long_name = var_name - endif - call ESMF_AttributeGet(field,name="UNITS",isPresent=is_present,_RC) - if ( is_present ) then - call ESMF_AttributeGet(field, NAME="UNITS",VALUE=units, _RC) - else - units = 'unknown' - endif - if (field_rank==2) then - vdims = "station_index,time" - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[nstation,1]) - else if (field_rank==3) then - vdims = "lev,station_index,time" - call ESMF_FieldGet(field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - v = variable(type=PFIO_REAL32,dimensions=trim(vdims),chunksizes=[ub(1)-lb(1)+1,1,1]) - end if - call v%add_attribute('units', trim(units)) - call v%add_attribute('long_name', trim(long_name)) - call v%add_attribute('missing_value', MAPL_UNDEF) - call v%add_attribute('_FillValue', MAPL_UNDEF) - call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) - call this%fmd%add_variable(trim(var_name),v,_RC) - end do - deallocate (fieldNameList) - - - !__ 3. locstream route handle - ! - call ESMF_FieldBundleGet(bundle,grid=grid,_RC) - this%regridder = LocStreamRegridder(grid,this%esmf_ls,_RC) - - - _RETURN(_SUCCESS) - end subroutine add_metadata_route_handle - - - subroutine append_file(this,current_time,rc) - class(StationSampler), intent(inout) :: this - type(ESMF_Time), intent(in) :: current_time - integer, optional, intent(out) :: rc - ! - integer :: status - integer :: fieldCount - integer :: ub(1), lb(1) - type(ESMF_Field) :: src_field,dst_field - real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) - real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) - real(kind=REAL32), allocatable :: arr(:,:) - character(len=ESMF_MAXSTR), allocatable :: fieldNameList(:) - character(len=ESMF_MAXSTR) :: xname - real(kind=ESMF_KIND_R8), allocatable :: rtimes(:) - integer :: i, rank - integer :: nx, nz - - this%obs_written=this%obs_written+1 - - !__ 1. put_var: time variable - ! - rtimes = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file - if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%setup_eta_to_pressure(_RC) - end if - if (mapl_am_i_root()) then - call this%formatter%put_var('time',rtimes(1:1),& - start=[this%obs_written],count=[1],_RC) - end if - - !__ 2. put_var: ungridded_dim from src to dst [regrid] - ! - call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount)) - call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) - do i=1, fieldCount - xname=trim(fieldNameList(i)) - call ESMF_FieldBundleGet(this%bundle,xname,field=src_field,_RC) - call ESMF_FieldGet(src_field,rank=rank,_RC) - if (rank==2) then - call ESMF_FieldGet(src_field,farrayptr=p_src_2d,_RC) - dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname, & - typekind=ESMF_TYPEKIND_R4,_RC) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_2d,_RC) - call this%regridder%regrid(p_src_2d,p_dst_2d,_RC) - if (mapl_am_i_root()) then - call this%formatter%put_var(xname,p_dst_2d,& - start=[1,this%obs_written],count=[this%nstation,1],_RC) - end if - call ESMF_FieldDestroy(dst_field,nogarbage=.true.) - else if (rank==3) then - call ESMF_FieldGet(src_field,farrayptr=p_src_3d,_RC) - call ESMF_FieldGet(src_field,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - if (this%vdata%lm/=(ub(1)-lb(1)+1)) then - lb(1)=1 - ub(1)=this%vdata%lm - end if - dst_field = ESMF_FieldCreate(this%esmf_ls,name=xname,& - typekind=ESMF_TYPEKIND_R4,ungriddedLBound=lb,ungriddedUBound=ub,_RC) - call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) - call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) - if (mapl_am_i_root()) then - nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx)) - arr=reshape(p_dst_3d,[nz,nx],order=[2,1]) - call this%formatter%put_var(xname,arr,& - start=[1,1,this%obs_written],count=[nz,nx,1],_RC) - !note: lev,station,time - deallocate(arr) - end if - call ESMF_FieldDestroy(dst_field,nogarbage=.true.) - else - _FAIL('grid2LS regridder: rank > 3 not implemented') - end if - end do - deallocate (fieldNameList) - _RETURN(_SUCCESS) - end subroutine append_file - - - subroutine create_file_handle(this,filename,rc) - class(StationSampler), intent(inout) :: this - character(len=*), intent(inout) :: filename ! for ouput nc - integer, optional, intent(out) :: rc - type(variable) :: v - integer :: status, j - - this%ofile = trim(filename) - v = this%time_info%define_time_variable(_RC) - call this%fmd%modify_variable('time',v,_RC) - this%obs_written = 0 - - if (.not. mapl_am_I_root()) then - _RETURN(_SUCCESS) - end if - call this%formatter%create(trim(filename),_RC) - call this%formatter%write(this%fmd,_RC) - call this%formatter%put_var('longitude',this%lons,_RC) - call this%formatter%put_var('latitude',this%lats,_RC) - call this%formatter%put_var('station_id',this%station_id,_RC) - call this%formatter%put_var('station_name',this%station_name,_RC) - - _RETURN(_SUCCESS) - end subroutine create_file_handle - - - subroutine close_file_handle(this,rc) - class(StationSampler), intent(inout) :: this - integer, optional, intent(out) :: rc - integer :: status - if (trim(this%ofile) /= '') then - if (mapl_am_i_root()) then - call this%formatter%close(_RC) - end if - end if - _RETURN(_SUCCESS) - end subroutine close_file_handle - - - function compute_time_for_current(this,current_time,rc) result(rtimes) - class(StationSampler), intent(inout) :: this - type(ESMF_Time), intent(in) :: current_time - integer, optional, intent(out) :: rc - real(ESMF_KIND_R8), allocatable :: rtimes(:) - integer :: status - type(ESMF_TimeInterval) :: tint - type(ESMF_Time) :: file_start_time - character(len=ESMF_MAXSTR) :: tunit - - allocate(rtimes(1),_STAT) - call this%get_file_start_time(file_start_time,tunit,_RC) - tint = current_time-file_start_time - select case(trim(tunit)) - case ('days') - call ESMF_TimeIntervalGet(tint,d_r8=rtimes(1),_RC) - case ('hours') - call ESMF_TimeIntervalGet(tint,h_r8=rtimes(1),_RC) - case ('minutes') - call ESMF_TimeIntervalGet(tint,m_r8=rtimes(1),_RC) - case default - _FAIL('illegal value for tunit: '//trim(tunit)) - end select - _RETURN(_SUCCESS) - end function compute_time_for_current - - - !-- a subroutine from MAPL_HistoryTrajectoryMod.F90 - ! TODO: consolidate with trajectory - subroutine get_file_start_time(this,start_time,time_units,rc) - class(StationSampler), intent(inout) :: this - type(ESMF_Time), intent(inout) :: start_time - character(len=*), intent(inout) :: time_units - integer, optional, intent(out) :: rc - - integer :: status - class(Variable), pointer :: var - type(Attribute), pointer :: attr - class(*), pointer :: pTimeUnits - character(len=ESMF_MAXSTR) :: timeUnits - - integer ypos(2), mpos(2), dpos(2), hpos(2), spos(2) - integer strlen - integer firstdash, lastdash - integer firstcolon, lastcolon - integer lastspace,since_pos - integer year,month,day,hour,min,sec - - var => this%fmd%get_variable('time',_RC) - attr => var%get_attribute('units') - ptimeUnits => attr%get_value() - select type(pTimeUnits) - type is (character(*)) - timeUnits = pTimeUnits - strlen = LEN_TRIM (TimeUnits) - - since_pos = index(TimeUnits, 'since') - time_units = trim(TimeUnits(:since_pos-1)) - time_units = trim(time_units) - - firstdash = index(TimeUnits, '-') - lastdash = index(TimeUnits, '-', BACK=.TRUE.) - - if (firstdash .LE. 0 .OR. lastdash .LE. 0) then - if (present(rc)) rc = -1 - return - endif - ypos(2) = firstdash - 1 - mpos(1) = firstdash + 1 - ypos(1) = ypos(2) - 3 - - mpos(2) = lastdash - 1 - dpos(1) = lastdash + 1 - dpos(2) = dpos(1) + 1 - - read ( TimeUnits(ypos(1):ypos(2)), * ) year - read ( TimeUnits(mpos(1):mpos(2)), * ) month - read ( TimeUnits(dpos(1):dpos(2)), * ) day - - firstcolon = index(TimeUnits, ':') - if (firstcolon .LE. 0) then - ! If no colons, check for hour. - ! Logic below assumes a null character or something else is after the hour - ! if we do not find a null character add one so that it correctly parses time - if (TimeUnits(strlen:strlen) /= C_NULL_CHAR) then - TimeUnits = trim(TimeUnits)//C_NULL_CHAR - strlen=len_trim(TimeUnits) - endif - lastspace = index(TRIM(TimeUnits), ' ', BACK=.TRUE.) - if ((strlen-lastspace).eq.2 .or. (strlen-lastspace).eq.3) then - hpos(1) = lastspace+1 - hpos(2) = strlen-1 - read (TimeUnits(hpos(1):hpos(2)), * ) hour - min = 0 - sec = 0 - else - hour = 0 - min = 0 - sec = 0 - endif - else - hpos(1) = firstcolon - 2 - hpos(2) = firstcolon - 1 - lastcolon = index(TimeUnits, ':', BACK=.TRUE.) - if ( lastcolon .EQ. firstcolon ) then - mpos(1) = firstcolon + 1 - mpos(2) = firstcolon + 2 - read (TimeUnits(hpos(1):hpos(2)), * ) hour - read (TimeUnits(mpos(1):mpos(2)), * ) min - sec = 0 - else - mpos(1) = firstcolon + 1 - mpos(2) = lastcolon - 1 - spos(1) = lastcolon + 1 - spos(2) = lastcolon + 2 - read (TimeUnits(hpos(1):hpos(2)), * ) hour - read (TimeUnits(mpos(1):mpos(2)), * ) min - read (TimeUnits(spos(1):spos(2)), * ) sec - endif - endif - class default - _FAIL("Time unit must be character") - end select - call ESMF_TimeSet(start_time,yy=year,mm=month,dd=day,h=hour,m=min,s=sec,_RC) - _RETURN(_SUCCESS) - end subroutine get_file_start_time - - ! TODO: delete and use system utilities when available - Subroutine count_substring (str, t, ncount, rc) - character (len=*), intent(in) :: str - character (len=*), intent(in) :: t - integer, intent(out) :: ncount - integer, optional, intent(out) :: rc - integer :: i, k, lt - integer :: status - ncount=0 - k=1 - lt = len(t) - 1 - do - i=index(str(k:), t) - if (i==0) exit - ncount = ncount + 1 - k=k+i+lt - end do - _RETURN(_SUCCESS) - end subroutine count_substring - - - subroutine CSV_read_line_with_CH_I_R(line, name, lon, lat, rc) - character (len=*), intent(in) :: line - character (len=*), intent(out) :: name - real(kind=REAL64), intent(out) :: lon, lat - integer, optional, intent(out) :: rc - integer :: n - integer :: i, j, k - integer :: status - - i=index(line, ',') - j=index(line(i+1:), ',') - _ASSERT (i>0, 'not CSV format') - _ASSERT (j>0, 'CSV format: find only 1 comma, should be > 1') - j=i+j - - read(line(1:i-1), '(a100)') name - k=index(line(i+1:j-1), '.') - if (k > 0) then - read(line(i+1:j-1), *) lon - else - read(line(i+1:j-1), *) i - lon = i - endif - - k=index(line(j+1:), '.') - if (k > 0) then - read(line(j+1:), *) lat - else - read(line(j+1:), *) i - lat = i - endif - - !!write(6,*) trim(name), lon, lat - _RETURN(_SUCCESS) - - end subroutine CSV_read_line_with_CH_I_R - -end module StationSamplerMod From 9d60a4ed9263906159c8aba5c43f8272711a26ce Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 13 Feb 2024 13:57:24 -0700 Subject: [PATCH 031/141] code clean up --- gridcomps/History/MAPL_HistoryGridComp.F90 | 15 --------------- .../History/Sampler/MAPL_GeosatMaskMod.F90 | 18 +++--------------- 2 files changed, 3 insertions(+), 30 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 09138f1a467d..b0006faa01bd 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3396,10 +3396,6 @@ subroutine Run ( gc, import, export, clock, rc ) Writing(n) = .false. else if (list(n)%timeseries_output) then Writing(n) = ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) - !! ygyu delete it - !! mask: use frequency - !! else if (list(n)%sampler_spec == 'mask') then - !! Writing(n) = ESMF_AlarmIsRinging ( list(n)%mask_sampler%alarm ) else if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then Writing(n) = ESMF_AlarmIsRinging ( Hsampler%alarm ) else @@ -3736,17 +3732,6 @@ subroutine Run ( gc, import, export, clock, rc ) call list(n)%trajectory%close_file_handle(_RC) call list(n)%trajectory%destroy_rh_regen_LS (_RC) end if - !! elseif (list(n)%sampler_spec == 'mask') then - - !! ygyu take action - ! output to files - - ! call list(n)%mask_sampler%find_mask(_RC) - ! if( ESMF_AlarmIsRinging ( list(n)%mask_sampler%alarm ) ) then - ! call list(n)%mask_sampler%append_file(current_time,_RC) - ! call list(n)%mask_sampler%close_file_handle(_RC) - ! end if - end if if( Writing(n) .and. list(n)%unit < 0) then diff --git a/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 b/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 index 69a83a0ac979..5674a1b2f1ca 100644 --- a/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 +++ b/gridcomps/History/Sampler/MAPL_GeosatMaskMod.F90 @@ -32,38 +32,26 @@ module MaskSamplerGeosatMod private ! character(len=:), allocatable :: grid_file_name character(len=ESMF_MAXSTR) :: grid_file_name - !-- ygyu we donot need LS - ! ! we need on each PET ! npt_mask, index_mask(1:2,npt_mask)=[i,j] ! integer :: npt_mask integer :: npt_mask_tot integer, allocatable :: index_mask(:,:) - ! - type(ESMF_FieldBundle) :: bundle - type(ESMF_FieldBundle) :: output_bundle - ! type(ESMF_FieldBundle) :: acc_bundle - ! type(ESMF_Field) :: fieldA - ! type(ESMF_Field) :: fieldB - + type(ESMF_FieldBundle) :: bundle type(GriddedIOitemVector) :: items type(VerticalData) :: vdata logical :: do_vertical_regrid - character(len=ESMF_MAXSTR) :: ofile type(TimeData) :: time_info type(ESMF_Clock) :: clock - type(ESMF_Alarm), public :: alarm type(ESMF_Time) :: RingTime type(ESMF_TimeInterval) :: epoch_frequency type(FileMetadata) :: metadata type(NetCDF4_FileFormatter) :: formatter - - - integer :: nobs_type + character(len=ESMF_MAXSTR) :: ofile + ! integer :: nobs integer :: obs_written - character(len=ESMF_MAXSTR) :: index_name_x character(len=ESMF_MAXSTR) :: index_name_y character(len=ESMF_MAXSTR) :: index_name_location From c7e31134046d6dd3fc4a1f5bf127d1e78a7a6f1a Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 13 Feb 2024 14:21:14 -0700 Subject: [PATCH 032/141] update --- CHANGELOG.md | 4 ++++ base/Base/Base_Base_implementation.F90 | 12 ++---------- gridcomps/History/MAPL_HistoryGridComp.F90 | 5 ----- 3 files changed, 6 insertions(+), 15 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ab56da24bb88..98a2b63d72f5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added + +- Add mask sampler for geostationary satellite (GEOS-R series) +- Add geostation name into NC for station sampler +- Add mapping between the IODA loc_index and trajectory NC output loc_index - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files - implemented a new algorthm to read tile files diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index dfeba20408e2..30e472bf869e 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2771,12 +2771,6 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, logical :: good_grid -! if (npts == 0 ) then -! _RETURN(_SUCCESS) -! endif - - write(6,*) 'pt 1' - if ( .not. present(grid)) then _FAIL("need a cubed-sphere grid") endif @@ -2791,8 +2785,6 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, good_grid = grid_is_ok(grid) _ASSERT( good_grid, "MAPL_GetGlobalHorzIJIndex cannot handle this grid") - write(6,*) 'pt 2' - allocate(lons(npts),lats(npts)) if (present(lon) .and. present(lat)) then lons = lon @@ -2825,7 +2817,7 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, II = -1 JJ = -1 - ! ygyu when npts=0 on localDE, + ! when npts=0 on localDE, return here if (npts == 0 ) then _RETURN(_SUCCESS) endif @@ -2857,7 +2849,7 @@ elemental subroutine calculate(x, y, z, i, j) elseif (abs(z-1.0d0) <= tolerance) then call angle_to_index(-x, -y, i, j) J = J + IM_WORLD*2 - ! face = 4 + ! face = 4 elseif (abs(x+1.0d0) <= tolerance) then call angle_to_index(-z, -y, i, j) J = J + IM_WORLD*3 diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index b0006faa01bd..2413b964c217 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -905,11 +905,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) if (list(n)%sampler_spec == 'trajectory') then list(n)%timeseries_output = .true. end if -!! if (rc==0) then -!! if (nline > 0) then -!! list(n)%timeseries_output = .true. -!! endif -!! endif ! Handle "backwards" mode: this is hidden (i.e. not documented) feature From e3ccc7ca6a97e74dcb2b215e4d43c5710d7d01fd Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Wed, 14 Feb 2024 08:52:51 -0500 Subject: [PATCH 033/141] Update base/Base/Base_Base_implementation.F90 --- base/Base/Base_Base_implementation.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 30e472bf869e..3147d457bfd0 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2817,10 +2817,8 @@ module subroutine MAPL_GetGlobalHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, II = -1 JJ = -1 - ! when npts=0 on localDE, return here - if (npts == 0 ) then - _RETURN(_SUCCESS) - endif + ! Return if no local points + _RETURN_IF(npts == 0) ! The edge points are assigned in the order of face 1,2,3,4,5,6 call calculate(x,y,z,II,JJ) From 50787be733717f982df31070ec9f61c8e43dfa90 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 14 Feb 2024 11:08:59 -0500 Subject: [PATCH 034/141] Fixes to allow SCM model to run --- CHANGELOG.md | 6 ++++-- base/FileIOShared.F90 | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ab56da24bb88..704d9bb5c728 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,12 +10,14 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files -- implemented a new algorthm to read tile files +- Implemented a new algorthm to read tile files ### Changed ### Fixed -- removed unnecessary memory allocation for tile reads. This is critical for high res runs on SCU17 + +- Removed unnecessary memory allocation for tile reads. This is critical for high res runs on SCU17 +- Fixes to allow SCM model to run ### Removed diff --git a/base/FileIOShared.F90 b/base/FileIOShared.F90 index 55f6f4423b8d..3b0d4ed75bd7 100644 --- a/base/FileIOShared.F90 +++ b/base/FileIOShared.F90 @@ -645,7 +645,7 @@ subroutine ArrDescrCreateReaderComm(arrdes, full_comm, num_readers, rc) nx = size(arrdes%i1) ny = size(arrdes%j1) - _ASSERT(num_readers < ny,'num readers must be less than NY') + _ASSERT(num_readers <= ny,'num readers must be less than or equal to NY') _ASSERT(mod(ny,num_readers)==0,'num readers must evenly divide NY') call mpi_comm_rank(full_comm,myid, _IERROR) From 6c7ffe006f9a9570a85f82048ba88679682071f3 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 15 Feb 2024 17:29:44 -0700 Subject: [PATCH 035/141] Corrections and changes for a better coding style --- base/MAPL_ObsUtil.F90 | 72 ++----------------- base/Plain_netCDF_Time.F90 | 49 ++----------- gridcomps/History/MAPL_HistoryGridComp.F90 | 33 ++++++--- .../Sampler/MAPL_StationSamplerMod.F90 | 17 +++-- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 28 ++++---- 5 files changed, 59 insertions(+), 140 deletions(-) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index fa8a5a53870c..c45749f0501b 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -58,11 +58,6 @@ module MAPL_ObsUtilMod module procedure sort_four_arrays_by_time end interface sort_multi_arrays_by_time - interface apply_order_index - module procedure apply_order_index_R8 - module procedure apply_order_index_I4 - end interface apply_order_index - contains subroutine get_obsfile_Tbracket_from_epoch(currTime, & @@ -218,19 +213,16 @@ subroutine create_timeunit (time, datetime_units, input_unit, rc) type(ESMF_Time), intent(in) :: time character(len=*), intent(out) :: datetime_units character(len=*), optional, intent(in) :: input_unit - integer, optional, intent(out) :: rc integer :: i, len integer :: status - character(len=20) :: string + character(len=ESMF_MAXSTR) :: string call ESMF_timeget (time, timestring=string, _RC) - if (present(input_unit)) then - datetime_units = trim(input_unit)//' since '//trim(string) - else - datetime_units = 'seconds since '//trim(string) - end if + datetime_units = 'seconds' + if (present(input_unit)) datetime_units = trim(input_unit) + datetime_units = trim(datetime_units) // trim(string) !!print*, 'datetime_units:', trim(datetime_units) _RETURN(_SUCCESS) @@ -313,27 +305,15 @@ subroutine Find_M_files_for_currTime (currTime, & call ESMF_TimeIntervalGet(dT1, s_r8=dT1_s, rc=status) call ESMF_TimeIntervalGet(dT2, s_r8=dT2_s, rc=status) - n1 = floor (dT1_s / dT0_s) + n1 = floor (dT1_s / dT0_s) - 1 ! downshift by 1, as filename does not guarantee accurate time n2 = floor (dT2_s / dT0_s) ! print*, 'ck dT0_s, dT1_s, dT2_s', dT0_s, dT1_s, dT2_s ! print*, '1st n1, n2', n1, n2 - obsfile_Ts_index = n1 - 1 ! downshift by 1 + obsfile_Ts_index = n1 obsfile_Te_index = n2 -! if ( dT2_s - n2*dT0_s < 1 ) then -! obsfile_Te_index = n2 - 1 -! else -! obsfile_Te_index = n2 -! end if - - - ! put back - n1 = obsfile_Ts_index - n2 = obsfile_Te_index -! print*, __LINE__, __FILE__ -! print*, '2nd n1, n2', n1, n2 !__ s2. further test file existence ! @@ -758,46 +738,6 @@ subroutine sort_index (X, IA, rc) end subroutine sort_index - subroutine apply_order_index_R8 (X, IA, rc) - use MAPL_SortMod - real(ESMF_KIND_R8), intent(inout) :: X(:) - integer, intent(in) :: IA(:) ! index - integer, optional, intent(out) :: rc - - integer :: i, len - real(ESMF_KIND_R8), allocatable :: XX(:) - - _ASSERT (size(X)==size(IA), 'X and IA (its index) differ in dimension') - len = size (X) - allocate (XX(len)) - XX(:) = X(:) - do i=1, len - X(i) = XX(IA(i)) - enddo - _RETURN(_SUCCESS) - - end subroutine apply_order_index_R8 - - subroutine apply_order_index_I4 (X, IA, rc) - use MAPL_SortMod - integer, intent(inout) :: X(:) - integer, intent(in) :: IA(:) ! index - integer, optional, intent(out) :: rc - - integer :: i, len - integer, allocatable :: XX(:) - - _ASSERT (size(X)==size(IA), 'X and IA (its index) differ in dimension') - len = size (X) - allocate (XX(len)) - XX(:) = X(:) - do i=1, len - X(i) = XX(IA(i)) - enddo - _RETURN(_SUCCESS) - - end subroutine apply_order_index_I4 - function copy_platform_nckeys(a, rc) type(obs_platform) :: copy_platform_nckeys type(obs_platform), intent(in) :: a diff --git a/base/Plain_netCDF_Time.F90 b/base/Plain_netCDF_Time.F90 index bd832853ceed..8733f178b3ab 100644 --- a/base/Plain_netCDF_Time.F90 +++ b/base/Plain_netCDF_Time.F90 @@ -389,20 +389,10 @@ subroutine time_esmf_2_nc_int(time, tunit, n, rc) type(ESMF_Time) :: time0 type(ESMF_TimeInterval) :: dt - character(len=ESMF_MAXSTR) :: STR1 - - n=0 call parse_timeunit(tunit, n, time0, dt, _RC) dt = time - time0 - !! test - !!write(6, '(2x,a,2x,a)') 'tunit=', trim(tunit) - !!call ESMF_TimeGet(time, timestring=STR1, _RC) - !!write(6, '(2x,a,2x,a)') 'time=', trim(STR1) - !!call ESMF_TimeGet(time0, timestring=STR1, _RC) - !!write(6, '(2x,a,2x,a)') 'time0=', trim(STR1) - ! assume unit is second ! call ESMF_TimeIntervalGet(dt, s_i8=n, _RC) @@ -426,33 +416,10 @@ subroutine parse_timeunit_i4(tunit, n, t0, dt, rc) type(ESMF_TimeInterval), intent(out) :: dt integer, optional, intent(out) :: rc integer :: status + integer(ESMF_KIND_I8) :: n8 - integer :: i - character(len=ESMF_MAXSTR) :: s1, s2, s_time, s_unit - character(len=1) :: c1 - integer :: y,m,d,hour,min,sec - integer :: isec - - i=index(trim(tunit), 'since') - s_time=trim(tunit(i+5:)) - s_unit=trim(tunit(1:i-1)) - read(s_time,*) s1, s2 - read(s1, '(i4,a1,i2,a1,i2)') y, c1, m, c1, d - read(s2, '(i2,a1,i2,a1,i2)') hour, c1, min, c1, sec - - if (trim(s_unit) == 'seconds') then - isec=n - elseif (trim(s_unit) == 'minutes') then - isec=n * 60 - elseif (trim(s_unit) == 'hours') then - isec=n * 3600 - else - _FAIL ('time_unit not implemented') - end if - - call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec,_RC) - call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s=isec, _RC) - + n8 = n + call parse_timeunit(tunit, n8, t0, dt, _RC) _RETURN(_SUCCESS) end subroutine parse_timeunit_i4 @@ -497,15 +464,16 @@ subroutine parse_timeunit_i8(tunit, n, t0, dt, rc) call ESMF_timeSet(t0, yy=y,mm=m,dd=d,h=hour,m=min,s=sec, _RC) call ESMF_timeintervalSet(dt, d=0, h=0, m=0, s_i8=isec, _RC) - _RETURN(_SUCCESS) end subroutine parse_timeunit_i8 - subroutine diff_two_timeunits (tunit1, tunit2, x, rc) + + subroutine diff_two_timeunits (tunit1, tunit2, x, dt_esmf, rc) character(len=*), intent(in) :: tunit1 character(len=*), intent(in) :: tunit2 real(ESMF_KIND_R8), intent(out) :: x + type(ESMF_TimeInterval), optional, intent(out) :: dt_esmf integer, intent(out), optional :: rc type(ESMF_Time) :: t1_base @@ -522,15 +490,14 @@ subroutine diff_two_timeunits (tunit1, tunit2, x, rc) call parse_timeunit (tunit1, n1, t1_base, dt1, _RC) call parse_timeunit (tunit2, n2, t2_base, dt2, _RC) deltaT_base = t2_base - t1_base + if (present(dt_esmf)) dt_esmf = deltaT_base i=index(trim(tunit1), 'since') s_unit=trim(tunit1(1:i-1)) - !! call ESMF_TimeIntervalGet(deltaT_base, s_r8=x, _RC) call ESMF_TimeIntervalGet(deltaT_base, s=sec, _RC) if (trim(s_unit) == 'seconds') then x = sec - ! pass elseif (trim(s_unit) == 'minutes') then x = sec / 60.d0 elseif (trim(s_unit) == 'hours') then @@ -548,8 +515,6 @@ subroutine diff_two_timeunits (tunit1, tunit2, x, rc) end subroutine diff_two_timeunits - - subroutine ESMF_time_to_two_integer(time, itime, rc) type(ESMF_Time), intent(in) :: time integer, intent(out) :: itime(2) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 2413b964c217..461d0cd0d90a 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -5346,7 +5346,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) do k=1, count call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, '.') j=index(line, ':') _ASSERT(i>1 .AND. j>1, 'keyword PLATFORM.X is not found') @@ -5357,35 +5358,40 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'index_name_x:', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, ':') PLFS(k)%index_name_x = trim(line(i+1:)) call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'var_name_lon:', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, ':') PLFS(k)%var_name_lon = trim(line(i+1:)) call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'var_name_lat:', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, ':') PLFS(k)%var_name_lat = trim(line(i+1:)) call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'var_name_time:', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, ':') PLFS(k)%var_name_time = trim(line(i+1:)) call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'file_name_template:', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, ':') PLFS(k)%file_name_template = trim(line(i+1:)) @@ -5405,7 +5411,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) do k=1, count call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, 'PLATFORM.') j=index(line, ':') marker=line(1:j) @@ -5415,7 +5422,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) ngeoval=0 nseg_ub=0 do while (ios == 0) - read (unitr, '(A)' ) line + read (unitr, '(A)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') con = (adjustl(trim(line))=='::') if (con) exit ngeoval = ngeoval + 1 @@ -5437,7 +5445,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) do k=1, count call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) - read(unitr, '(a)') line + read(unitr, '(a)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') i=index(line, 'PLATFORM.') j=index(line, ':') marker=line(1:j) @@ -5447,7 +5456,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) ios=0 ngeoval=0 do while (ios == 0) - read (unitr, '(A)', iostat = ios) line + read (unitr, '(A)', iostat=ios) line + _ASSERT (ios==0, 'read line failed') !! write(6,*) 'k in count, line', k, trim(line) con = .not.(adjustl(trim(line))=='::') if (con) then @@ -5484,7 +5494,8 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) contLine = .false. obs_flag = .false. do while (.true.) - read(unitr, '(A)', end=1236) line + read(unitr, '(A)', iostat=ios, end=1236) line + _ASSERT (ios==0, 'read line failed') j = index( adjustl(line), trim(adjustl(string)) ) match = (j == 1) if (match) then diff --git a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 index 633ffe0e9847..722c658c1f60 100644 --- a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 @@ -577,7 +577,6 @@ Subroutine count_substring (str, t, ncount, rc) integer, intent(out) :: ncount integer, optional, intent(out) :: rc integer :: i, k, lt - integer :: status ncount=0 k=1 lt = len(t) - 1 @@ -598,7 +597,7 @@ subroutine CSV_read_line_with_CH_I_R(line, name, lon, lat, rc) integer, optional, intent(out) :: rc integer :: n integer :: i, j, k - integer :: status + integer :: ios i=index(line, ',') j=index(line(i+1:), ',') @@ -606,22 +605,26 @@ subroutine CSV_read_line_with_CH_I_R(line, name, lon, lat, rc) _ASSERT (j>0, 'CSV format: find only 1 comma, should be > 1') j=i+j - read(line(1:i-1), '(a100)') name + read(line(1:i-1), '(a100)', iostat=ios) name + _ASSERT (ios==0, 'read error') k=index(line(i+1:j-1), '.') if (k > 0) then - read(line(i+1:j-1), *) lon + read(line(i+1:j-1), *, iostat=ios) lon else - read(line(i+1:j-1), *) i + read(line(i+1:j-1), *, iostat=ios) i lon = i endif + _ASSERT (ios==0, 'read error') + k=index(line(j+1:), '.') if (k > 0) then - read(line(j+1:), *) lat + read(line(j+1:), *, iostat=ios) lat else - read(line(j+1:), *) i + read(line(j+1:), *, iostat=ios) i lat = i endif + _ASSERT (ios==0, 'read error') !!write(6,*) trim(name), lon, lat _RETURN(_SUCCESS) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 165c40a42331..971c630f4f29 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -306,11 +306,11 @@ call v%add_attribute('long_name', 'dateTime') call this%obs(k)%metadata%add_variable(this%var_name_time,v) - v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) + v = Variable(type=PFIO_INT32,dimensions=this%index_name_x) call v%add_attribute('units', '1') call v%add_attribute('long_name', 'Location index in corresponding IODA file') call this%obs(k)%metadata%add_variable(this%location_index_name,v) - + v = variable(type=PFIO_REAL64,dimensions=this%index_name_x) call v%add_attribute('units','degrees_east') call v%add_attribute('long_name','longitude') @@ -501,7 +501,7 @@ real(kind=REAL64), allocatable :: times_R8_full(:) real(kind=REAL64) :: t_shift integer, allocatable :: obstype_id_full(:) - integer, allocatable :: location_index_ioda_full(:) + integer, allocatable :: location_index_ioda_full(:) integer, allocatable :: IA_full(:) real(ESMF_KIND_R8), pointer :: ptAT(:) @@ -559,7 +559,7 @@ i=index(this%var_name_time_full, '/') this%var_name_time= this%var_name_time_full(i+1:) this%location_index_name = 'location_index_in_iodafile' - + call lgr%debug('%a', 'grp_name,this%index_name_x,this%var_name_lon,this%var_name_lat,this%var_name_time') call lgr%debug('%a %a %a %a %a', & trim(grp_name),trim(this%index_name_x),trim(this%var_name_lon),& @@ -599,7 +599,7 @@ allocate(lons_full(len),lats_full(len),_STAT) allocate(times_R8_full(len),_STAT) allocate(obstype_id_full(len),_STAT) - allocate(location_index_ioda_full(len),_STAT) + allocate(location_index_ioda_full(len),_STAT) allocate(IA_full(len),_STAT) call lgr%debug('%a %i12', 'nobs from input file:', len) len = 0 @@ -642,7 +642,7 @@ allocate(this%lons(0),this%lats(0),_STAT) allocate(this%times_R8(0),_STAT) allocate(this%obstype_id(0),_STAT) - allocate(this%location_index_ioda(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) this%epoch_index(1:2) = 0 this%nobs_epoch = 0 this%nobs_epoch_sum = 0 @@ -665,7 +665,7 @@ if (mapl_am_I_root()) then call sort_index (times_R8_full, IA_full, _RC) - call apply_order_index (location_index_ioda_full, IA_full, _RC) + location_index_ioda_full(:) = IA_full(:) ! NVHPC dies with NVFORTRAN-S-0155-Could not resolve generic procedure sort_multi_arrays_by_time call sort_four_arrays_by_time(lons_full, lats_full, times_R8_full, obstype_id_full, _RC) call ESMF_ClockGet(this%clock,currTime=current_time,_RC) @@ -709,7 +709,7 @@ allocate(this%lons(0),this%lats(0),_STAT) allocate(this%times_R8(0),_STAT) allocate(this%obstype_id(0),_STAT) - allocate(this%location_index_ioda(0),_STAT) + allocate(this%location_index_ioda(0),_STAT) this%epoch_index(1:2)=0 this%nobs_epoch = 0 nx=0 @@ -739,7 +739,7 @@ allocate(this%lons(nx),this%lats(nx),_STAT) allocate(this%times_R8(nx),_STAT) allocate(this%obstype_id(nx),_STAT) - allocate(this%location_index_ioda(nx),_STAT) + allocate(this%location_index_ioda(nx),_STAT) j=this%epoch_index(1) do i=1, nx @@ -747,7 +747,7 @@ this%lats(i) = lats_full(j) this%times_R8(i) = times_R8_full(j) this%obstype_id(i) = obstype_id_full(j) - this%location_index_ioda(i) = location_index_ioda_full(j) + this%location_index_ioda(i) = location_index_ioda_full(j) j=j+1 enddo arr(1)=nx @@ -765,7 +765,7 @@ allocate (this%obs(k)%lons(nx2)) allocate (this%obs(k)%lats(nx2)) allocate (this%obs(k)%times_R8(nx2)) - allocate (this%obs(k)%location_index_ioda(nx2)) + allocate (this%obs(k)%location_index_ioda(nx2)) enddo allocate(ix(this%nobs_type)) @@ -777,7 +777,7 @@ this%obs(k)%lons(ix(k)) = lons_full(j) this%obs(k)%lats(ix(k)) = lats_full(j) this%obs(k)%times_R8(ix(k)) = times_R8_full(j) - this%obs(k)%location_index_ioda(ix(k)) = location_index_ioda_full(j) + this%obs(k)%location_index_ioda(ix(k)) = location_index_ioda_full(j) !if (mod(k,10**8)==1) then ! write(6,*) 'this%obs(k)%times_R8(ix(k))', this%obs(k)%times_R8(ix(k)) !endif @@ -810,7 +810,7 @@ this%nobs_epoch_sum = nx_sum call lgr%debug('%a %i20', 'nobservation points=', nx_sum) - + this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) this%LS_rt = this%locstream_factory%create_locstream(_RC) call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) @@ -883,7 +883,7 @@ call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & start=[is], count=[nx], _RC) call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & - start=[is], count=[nx], _RC) + start=[is], count=[nx], _RC) end if end if enddo From 7ae7f770135ff390a7027b149ae297e71cd3f059 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 15 Feb 2024 17:39:32 -0700 Subject: [PATCH 036/141] start debug --- base/MAPL_SwathGridFactory.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index 01bed4e9ba7e..ba2f88f82643 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -476,6 +476,11 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%nx, label=prefix//'NX:', default=MAPL_UNDEFINED_INTEGER) call ESMF_ConfigGetAttribute(config, this%ny, label=prefix//'NY:', default=MAPL_UNDEFINED_INTEGER) call ESMF_ConfigGetAttribute(config, this%lm, label=prefix//'LM:', default=MAPL_UNDEFINED_INTEGER) + + print*, 'nx,ny,lm', this%nx, this%ny, this%lm + _FAIL('X1') + + call ESMF_ConfigGetAttribute(config, this%input_template, label=prefix//'GRID_FILE:', default='unknown.txt', _RC) call ESMF_ConfigGetAttribute(config, this%epoch, label=prefix//'Epoch:', default=300, _RC) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'Epoch_init:', default='2006', _RC) From f13d793c3e8c37933444c63bb6c17c146dd1a7d4 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 15 Feb 2024 21:54:12 -0700 Subject: [PATCH 037/141] . --- base/MAPL_SwathGridFactory.F90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/base/MAPL_SwathGridFactory.F90 b/base/MAPL_SwathGridFactory.F90 index ba2f88f82643..93bf1b563c41 100644 --- a/base/MAPL_SwathGridFactory.F90 +++ b/base/MAPL_SwathGridFactory.F90 @@ -476,14 +476,10 @@ subroutine initialize_from_config_with_prefix(this, config, prefix, unusable, rc call ESMF_ConfigGetAttribute(config, this%nx, label=prefix//'NX:', default=MAPL_UNDEFINED_INTEGER) call ESMF_ConfigGetAttribute(config, this%ny, label=prefix//'NY:', default=MAPL_UNDEFINED_INTEGER) call ESMF_ConfigGetAttribute(config, this%lm, label=prefix//'LM:', default=MAPL_UNDEFINED_INTEGER) - - print*, 'nx,ny,lm', this%nx, this%ny, this%lm - _FAIL('X1') - - call ESMF_ConfigGetAttribute(config, this%input_template, label=prefix//'GRID_FILE:', default='unknown.txt', _RC) call ESMF_ConfigGetAttribute(config, this%epoch, label=prefix//'Epoch:', default=300, _RC) call ESMF_ConfigGetAttribute(config, tmp, label=prefix//'Epoch_init:', default='2006', _RC) + _ASSERT (this%lm /= MAPL_UNDEFINED_INTEGER, 'LM: is undefined in swath grid') call lgr%debug(' %a %a', 'CurrTime =', trim(tmp)) From d0d1ac356f18f645aaad4be063b3c7ff66892915 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Fri, 16 Feb 2024 12:16:16 -0500 Subject: [PATCH 038/141] Bypass i_clients call when there is no Extdata --- CHANGELOG.md | 2 ++ gridcomps/ExtData/ExtDataGridCompMod.F90 | 9 +++++++++ 2 files changed, 11 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index ab56da24bb88..10a1e9ac244a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Bypassed the I-Server reading call when there is no extdata + ### Fixed - removed unnecessary memory allocation for tile reads. This is critical for high res runs on SCU17 diff --git a/gridcomps/ExtData/ExtDataGridCompMod.F90 b/gridcomps/ExtData/ExtDataGridCompMod.F90 index 729ef9b78559..63b3ac6ed89c 100644 --- a/gridcomps/ExtData/ExtDataGridCompMod.F90 +++ b/gridcomps/ExtData/ExtDataGridCompMod.F90 @@ -1432,6 +1432,15 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call lgr%debug('ExtData Run_: READ_LOOP: Done') + if (IOBundles%size() == 0) then + deallocate(doUpdate) + deallocate(useTime) + if (hasRun .eqv. .false.) hasRun = .true. + call MAPL_TimerOff(MAPLSTATE,"-Read_Loop") + call MAPL_TimerOff(MAPLSTATE,"Run") + _RETURN(ESMF_SUCCESS) + endif + bundle_iter = IOBundles%begin() do while (bundle_iter /= IoBundles%end()) io_bundle => bundle_iter%get() From e25861ba83d2ccc0517cde4c74e64c9a993102fe Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 20 Feb 2024 10:34:24 -0700 Subject: [PATCH 039/141] fix a bug in reading lat/lon in NOAA GHCNd (the order differs from Aeronet) --- gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 index 722c658c1f60..43d87bffacfe 100644 --- a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 @@ -160,12 +160,12 @@ function new_StationSampler_readfile (filename,nskip_line, rc) result(sampler) sampler%lats(i), _RC) sampler%station_id(i)=i elseif(trim(seq)=='AFFFA') then - ! Ex: 'ZI000067991 -22.2170 30.0000 457.0 BEITBRIDGE 67991' + ! NOAA GHCNd + ! Ex: 'CHM00054511 39.9330 116.2830 55.0 BEIJING GSN 54511' read(unit, *) & sampler%station_name(i), & - sampler%lons(i), & - sampler%lats(i) - + sampler%lats(i), & + sampler%lons(i) sampler%station_id(i)=i backspace(unit) read(unit, '(a100)', IOSTAT=ios) line From e48115790bd90091f8d8cde6d9e55a3c0261b6b5 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Tue, 20 Feb 2024 16:39:32 -0500 Subject: [PATCH 040/141] add per collection timers --- gridcomps/History/MAPL_HistoryGridComp.F90 | 54 +++++++++++----------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 9f5329b99ec5..4201789e2dba 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3320,7 +3320,7 @@ subroutine Run ( gc, import, export, clock, rc ) do n=1,nlist if(Ignore(n)) cycle if ( Any(list(n)%ReWrite) ) then - call MAPL_TimerOn(GENSTATE,"-ParserRun") + call MAPL_TimerOn(GENSTATE,"ParserRun") if( (.not.list(n)%disabled .and. IntState%average(n)) ) then call MAPL_RunExpression(IntState%CIM(n),list(n)%field_set%fields,list(n)%tmpfields, & list(n)%ReWrite,list(n)%field_set%nfields,_RC) @@ -3329,7 +3329,7 @@ subroutine Run ( gc, import, export, clock, rc ) call MAPL_RunExpression(IntState%GIM(n),list(n)%field_set%fields,list(n)%tmpfields, & list(n)%ReWrite,list(n)%field_set%nfields,_RC) end if - call MAPL_TimerOff(GENSTATE,"-ParserRun") + call MAPL_TimerOff(GENSTATE,"ParserRun") endif end do @@ -3348,7 +3348,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! Couplers are done here for now !------------------------------- - call MAPL_TimerOn(GENSTATE,"--Couplers") + call MAPL_TimerOn(GENSTATE,"Couplers") do n = 1, nlist if(Ignore(n)) cycle if (.not.list(n)%disabled .and. IntState%average(n)) then @@ -3368,7 +3368,7 @@ subroutine Run ( gc, import, export, clock, rc ) _VERIFY(STATUS) end if end do - call MAPL_TimerOff(GENSTATE,"--Couplers") + call MAPL_TimerOff(GENSTATE,"Couplers") ! Check for History Output ! ------------------------ @@ -3434,6 +3434,8 @@ subroutine Run ( gc, import, export, clock, rc ) ! swath only epoch_swath_grid_case: do n=1,nlist + call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) + call MAPL_TimerOn(GENSTATE,"SwathGen") if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then call Hsampler%regrid_accumulate(list(n)%xsampler,_RC) @@ -3460,18 +3462,18 @@ subroutine Run ( gc, import, export, clock, rc ) call list(n)%mGriddedIO%set_param(write_collection_id=collection_id) endif end if + call MAPL_TimerOff(GENSTATE,"SwathGen") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) end do epoch_swath_grid_case ! Write Id and time ! ----------------- - call MAPL_TimerOn(GENSTATE,"--I/O") - - call MAPL_TimerOn(GENSTATE,"----IO Create") - if (any(writing)) call o_Clients%set_optimal_server(count(writing)) OPENLOOP: do n=1,nlist + call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) + call MAPL_TimerOn(GENSTATE,"IO Create") if( Writing(n) ) then call get_DateStamp ( clock, DateStamp=DateStamp, & @@ -3559,13 +3561,14 @@ subroutine Run ( gc, import, export, clock, rc ) end if ! + call MAPL_TimerOff(GENSTATE,"IO Create") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) enddo OPENLOOP - call MAPL_TimerOff(GENSTATE,"----IO Create") - call MAPL_TimerOn(GENSTATE,"----IO Write") - call MAPL_TimerOn(GENSTATE,"-----IO Post") POSTLOOP: do n=1,nlist + call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) + call MAPL_TimerOn(GENSTATE,"IO Post") OUTTIME: if( Writing(n) ) then @@ -3652,23 +3655,23 @@ subroutine Run ( gc, import, export, clock, rc ) list(n)%unit = 0 endif + call MAPL_TimerOff(GENSTATE,"IO Post") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) enddo POSTLOOP + call MAPL_TimerOn(GENSTATE,"Done Wait") if (any(writing)) then call o_Clients%done_collective_stage(_RC) call o_Clients%post_wait() endif - call MAPL_TimerOff(GENSTATE,"-----IO Post") - call MAPL_TimerOff(GENSTATE,"----IO Write") - - call MAPL_TimerOn(GENSTATE,"----IO Write") - call MAPL_TimerOn(GENSTATE,"-----IO Wait") - + call MAPL_TimerOff(GENSTATE,"Done Wait") ! destroy ogrid/RH/acc_bundle, regenerate them ! swath only epoch_swath_regen_grid: do n=1,nlist + call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) + call MAPL_TimerOn(GENSTATE,"Swath regen") if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then @@ -3681,6 +3684,8 @@ subroutine Run ( gc, import, export, clock, rc ) if( MAPL_AM_I_ROOT() ) write(6,'(//)') endif end if + call MAPL_TimerOff(GENSTATE,"Swath regen") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) end do epoch_swath_regen_grid @@ -3693,14 +3698,10 @@ subroutine Run ( gc, import, export, clock, rc ) enddo WAITLOOP - call MAPL_TimerOff(GENSTATE,"-----IO Wait") - call MAPL_TimerOff(GENSTATE,"----IO Write") - - call MAPL_TimerOn(GENSTATE,"----IO Write") - call MAPL_TimerOn(GENSTATE,"-----IO Write") - WRITELOOP: do n=1,nlist + call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) + call MAPL_TimerOn(GENSTATE,"Write Timeseries") if (list(n)%timeseries_output) then call list(n)%trajectory%regrid_accumulate(_RC) if( ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) ) then @@ -3716,13 +3717,10 @@ subroutine Run ( gc, import, export, clock, rc ) end if + call MAPL_TimerOff(GENSTATE,"Write Timeseries") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) enddo WRITELOOP - call MAPL_TimerOff(GENSTATE,"-----IO Write") - call MAPL_TimerOff(GENSTATE,"----IO Write") - - call MAPL_TimerOff(GENSTATE,"--I/O" ) - if(any(Writing)) call WRITE_PARALLEL("") deallocate(NewSeg) From 8f4fb151793bbd34f4755fcedef155b5806e538c Mon Sep 17 00:00:00 2001 From: "dependabot[bot]" <49699333+dependabot[bot]@users.noreply.github.com> Date: Tue, 20 Feb 2024 23:17:58 +0000 Subject: [PATCH 041/141] Bump CircleCI-Public/trigger-circleci-pipeline-action Bumps [CircleCI-Public/trigger-circleci-pipeline-action](https://github.com/circleci-public/trigger-circleci-pipeline-action) from 1.1.0 to 1.2.0. - [Release notes](https://github.com/circleci-public/trigger-circleci-pipeline-action/releases) - [Commits](https://github.com/circleci-public/trigger-circleci-pipeline-action/compare/v1.1.0...v1.2.0) --- updated-dependencies: - dependency-name: CircleCI-Public/trigger-circleci-pipeline-action dependency-type: direct:production update-type: version-update:semver-minor ... Signed-off-by: dependabot[bot] --- .github/workflows/trigger-circleci-pipeline-on-release.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/trigger-circleci-pipeline-on-release.yml b/.github/workflows/trigger-circleci-pipeline-on-release.yml index 67e81a5fa04e..8f5aa8d3a8df 100644 --- a/.github/workflows/trigger-circleci-pipeline-on-release.yml +++ b/.github/workflows/trigger-circleci-pipeline-on-release.yml @@ -7,6 +7,6 @@ jobs: steps: - name: CircleCI Trigger on Release id: docker-build - uses: CircleCI-Public/trigger-circleci-pipeline-action@v1.1.0 + uses: CircleCI-Public/trigger-circleci-pipeline-action@v1.2.0 env: CCI_TOKEN: ${{ secrets.CCI_TOKEN }} From b5e2bf2a8b59604362c84321400b12c2ff37b53e Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 21 Feb 2024 15:51:09 -0500 Subject: [PATCH 042/141] add per collection History timers --- CHANGELOG.md | 1 + gridcomps/History/MAPL_HistoryGridComp.F90 | 6 ++++-- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 10a1e9ac244a..483c60da6578 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Add per-collection timer output for History - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files - implemented a new algorthm to read tile files diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 4201789e2dba..8088a4c11421 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3348,8 +3348,9 @@ subroutine Run ( gc, import, export, clock, rc ) ! Couplers are done here for now !------------------------------- - call MAPL_TimerOn(GENSTATE,"Couplers") do n = 1, nlist + call MAPL_TimerOn(GENSTATE,trim(list(n)%collection)) + call MAPL_TimerOn(GENSTATE,"Couplers") if(Ignore(n)) cycle if (.not.list(n)%disabled .and. IntState%average(n)) then ! R8 to R4 copy (if needed!) @@ -3367,8 +3368,9 @@ subroutine Run ( gc, import, export, clock, rc ) userRC=STATUS) _VERIFY(STATUS) end if + call MAPL_TimerOff(GENSTATE,"Couplers") + call MAPL_TimerOff(GENSTATE,trim(list(n)%collection)) end do - call MAPL_TimerOff(GENSTATE,"Couplers") ! Check for History Output ! ------------------------ From 9919c588f2b57a6766ae1e7a0d40563fcf7490d5 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 21 Feb 2024 16:13:28 -0700 Subject: [PATCH 043/141] update regen_rcx_for_obs_platform filtering lines with # --- gridcomps/History/MAPL_HistoryGridComp.F90 | 91 ++++++++++--------- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 19 +++- 2 files changed, 64 insertions(+), 46 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 461d0cd0d90a..dfb0786a6e82 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -5298,7 +5298,7 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) character(len=ESMF_MAXSTR) :: HIST_CF integer :: n, unitr, unitw - logical :: match, contLine, con + logical :: match, contLine, con, con2 integer :: status character (len=ESMF_MAXSTR) :: marker @@ -5327,14 +5327,13 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) label="HIST_CF:", default="HIST.rc", _RC ) unitr = GETFILE(HIST_CF, FORM='formatted', _RC) - call scan_count_match_bgn (unitr, 'PLATFORM.', count, .false.) + call scan_count_match_bgn (unitr, 'PLATFORM.', nplf, .false.) rewind(unitr) - call lgr%debug('%a %i8','count PLATFORM.', count) - if (count==0) then + + if (nplf==0) then rc = 0 return endif - nplf = count allocate (PLFS(nplf)) allocate (map(nplf)) @@ -5342,8 +5341,9 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) length_mx = ESMF_MAXSTR2 mxseg = 100 + ! __ s1. scan get platform name + index_name_x var_name_lat/lon/time - do k=1, count + do k=1, nplf call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) read(unitr, '(a)', iostat=ios) line @@ -5354,7 +5354,6 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) PLFS(k)%name = line(i+1:j-1) marker=line(1:j) - call lgr%debug('%a %a', 'marker=', trim(marker)) call scan_contain(unitr, marker, .true.) call scan_contain(unitr, 'index_name_x:', .false.) backspace(unitr) @@ -5405,18 +5404,12 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) end do - ! __ s2.1 scan fields: get ngeoval / nentry_name = nword + + ! __ s2.1 scan fields: only determine ngeoval / nentry_name = nword allocate (str_piece(mxseg)) rewind(unitr) - do k=1, count + do k=1, nplf call scan_begin(unitr, 'PLATFORM.', .false.) - backspace(unitr) - read(unitr, '(a)', iostat=ios) line - _ASSERT (ios==0, 'read line failed') - i=index(line, 'PLATFORM.') - j=index(line, ':') - marker=line(1:j) - call scan_begin(unitr, marker, .true.) call scan_contain(unitr, 'geovals_fields:', .false.) ios=0 ngeoval=0 @@ -5426,23 +5419,26 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) _ASSERT (ios==0, 'read line failed') con = (adjustl(trim(line))=='::') if (con) exit - ngeoval = ngeoval + 1 - call split_string_by_space (line, length_mx, mxseg, & - nseg, str_piece, status) - nseg_ub = max(nseg_ub, nseg) + !! print *, 'line, con', trim(line), con + con2= (index ( adjustl(line), '#' ) == 1) ! skip comment line + if ( .not. con2 ) then + ngeoval = ngeoval + 1 + call split_string_by_space (line, length_mx, mxseg, & + nseg, str_piece, status) + nseg_ub = max(nseg_ub, nseg) + end if enddo PLFS(k)%ngeoval = ngeoval PLFS(k)%nentry_name = nseg_ub -!! call lgr%debug('%a %i','ngeoval=', ngeoval) allocate ( PLFS(k)%field_name (nseg_ub, ngeoval) ) PLFS(k)%field_name = '' -!! nentry_name = nseg_ub ! assume the same for each field_name + !! print*, 'k, ngeoval, nentry_name', k, ngeoval, nseg_ub end do ! __ s2.2 scan fields: get splitted PLFS(k)%field_name rewind(unitr) - do k=1, count + do k=1, nplf call scan_begin(unitr, 'PLATFORM.', .false.) backspace(unitr) read(unitr, '(a)', iostat=ios) line @@ -5458,29 +5454,39 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) do while (ios == 0) read (unitr, '(A)', iostat=ios) line _ASSERT (ios==0, 'read line failed') - !! write(6,*) 'k in count, line', k, trim(line) - con = .not.(adjustl(trim(line))=='::') - if (con) then + !! write(6,*) 'k in nplf, line', k, trim(line) + con = (adjustl(trim(line))=='::') + if (con) exit + con2= (index ( adjustl(line), '#' ) == 1) ! skip comment line + if (.NOT.con2) then ngeoval = ngeoval + 1 call split_string_by_space (line, length_mx, mxseg, & nseg, str_piece, status) do m=1, nseg PLFS(k)%field_name (m, ngeoval) = trim(str_piece(m)) end do - else - exit endif enddo end do deallocate(str_piece) rewind(unitr) - !!do k=1, nplf - !! do i=1, ngeoval - !! write(6,*) 'PLFS(k)%field_name (1:nseg, ngeoval)=', PLFS(k)%field_name (1:nseg,1) - !! enddo - !!enddo - !!write(6,*) 'nlist=', nlist + + call lgr%debug('%a %i8','count PLATFORM.', nplf) + if (mapl_am_i_root()) then + do k=1, nplf + write(6, '(10x,a,i3,a,2x,a)') 'PLFS(', k, ') =', trim(PLFS(k)%name) + do i=1, size(PLFS(k)%field_name, 2) + line='' + do j=1, size(PLFS(k)%field_name, 1) + write(line2, '(a)') trim(PLFS(k)%field_name(j,i)) + line=trim(line)//trim(line2) + end do + write(6, '(24x,a)') trim(line) + enddo + enddo + end if +!! write(6,*) 'nlist=', nlist ! __ s3: Add more entry: 'obs_files:' and 'fields:' to rcx @@ -5511,14 +5517,13 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) if ( index(adjustl(line), trim(string)//'ObsPlatforms:') == 1 ) then obs_flag =.true. line2 = line - write(6,*) 'first line for ObsPlatforms:=', trim(line) - + !! write(6,*) 'first line for ObsPlatforms:=', trim(line) endif end do 1236 continue - if (obs_flag) then + if (obs_flag) then allocate (str_piece(mxseg)) i = index(line2, ':') line = adjustl ( line2(i+1:) ) @@ -5526,14 +5531,10 @@ subroutine regen_rcx_for_obs_platform (config, nlist, list, rc) nplatform, str_piece, status) !! to do: add debug - !!write(6,*) 'line for obsplatforms=', trim(line) - !!write(6,*) 'split string, nplatform=', nplatform - !!write(6,*) 'nplf=', nplf - - !!write(6,*) 'str_piece=', str_piece(1:nplatform) - !!do j=1, nplf - !! write(6,*) 'PLFS(j)%name=', trim( PLFS(j)%name ) - !!enddo + !write(6,*) 'line for obsplatforms=', trim(line) + !write(6,*) 'split string, nplatform=', nplatform + !write(6,*) 'nplf=', nplf + !write(6,*) 'str_piece=', str_piece(1:nplatform) ! diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 971c630f4f29..d75ac1813399 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -249,6 +249,9 @@ type(ESMF_Time) :: currTime integer :: k +! if (mapl_am_i_root()) write(6,'(2x,a,10(2x,L5))') & +! 'traj initialize_ : present(reinitialize), reinitialize =', & +! present(reinitialize), reinitialize if (.not. present(reinitialize)) then if(present(bundle)) this%bundle=bundle if(present(items)) this%items=items @@ -258,6 +261,8 @@ else this%vdata=VerticalData(_RC) end if + !if (mapl_am_i_root()) write(6,'(2x,a,10(2x,L5))') & + ! 'traj initialize_ : initialize : not present ' else if (reinitialize) then do k=1, this%nobs_type @@ -266,6 +271,8 @@ allocate (this%obs(k)%file_handle) end if end do + !if (mapl_am_i_root()) write(6,'(2x,a,10(2x,L5))') & + ! 'traj initialize_ : initialize : TRUE' end if end if @@ -326,6 +333,9 @@ iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() + +!! print*, 'list item%xname', trim(item%xname) + if (item%itemType == ItemTypeScalar) then call this%create_variable(item%xname,_RC) else if (item%itemType == ItemTypeVector) then @@ -335,6 +345,7 @@ call iter%next() enddo + _RETURN(_SUCCESS) end procedure initialize_ @@ -379,6 +390,12 @@ do ig = 1, this%obs(k)%ngeoval if (trim(var_name) == trim(this%obs(k)%geoval_name(ig))) then call this%obs(k)%metadata%add_variable(trim(var_name),v,_RC) + +!! if (mapl_am_i_root()) write(6, '(2x,a,/,10(2x,a))') & +!! 'Traj: create_metadata_variable: vname, var_name, this%obs(k)%geoval_name(ig)', & +!! trim(vname), trim(var_name), trim(this%obs(k)%geoval_name(ig)) + + endif enddo enddo @@ -904,7 +921,7 @@ iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() - !!write(6, '(2x,a,2x,a)') 'item%xname', trim(item%xname) + if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'item%xname', trim(item%xname) if (item%itemType == ItemTypeScalar) then call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) From 34e84a2fabcb9cb3c8eafbcbd38c7117a466edfe Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 22 Feb 2024 15:16:23 -0500 Subject: [PATCH 044/141] updates to fix scm and then some... --- base/NCIO.F90 | 64 ++++++++++++++++------------------------ generic/MAPL_Generic.F90 | 63 ++++++++++++++++++++++----------------- 2 files changed, 62 insertions(+), 65 deletions(-) diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 571892359e15..35037294b65c 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -311,7 +311,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients integer :: J,K type (ESMF_DistGrid) :: distGrid type (LocalMemReference) :: lMemRef - type (LocalMemReference) :: lMemRef_vec(6) + type (LocalMemReference), allocatable :: lMemRef_vec(:) integer :: size_1d logical :: have_oclients character(len=:), allocatable :: fname_by_writer @@ -325,6 +325,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients have_oclients = present(oClients) + call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) _VERIFY(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then @@ -340,6 +341,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients _VERIFY(STATUS) call ESMF_ArrayGet(array, typekind=tk, rank=rank, rc=status) _VERIFY(STATUS) + call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) if (rank == 1) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_1d, rc=status) @@ -364,8 +366,25 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call ArrayGather(var_1d, gvar_1d, grid, mask=mask, rc=status) endif - call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1], & - global_start=[1], global_count=[size_1d]) + if (dims == MAPL_DimsVertOnly .and. arrdes%split_checkpoint) then + allocate(lMemRef_vec(arrdes%num_writers)) + do j=1,arrdes%num_writers + fname_by_writer = get_fname_by_rank(trim(arrdes%filename),j-1) + if (mapl_am_i_root()) then + lMemRef_vec(j) = LocalMemReference(pFIO_REAL32,[size_1d]) + call c_f_pointer(lMemRef_vec(j)%base_address, gvar_1d, shape=[size_1d]) + gvar_1d = var_1d + else + lMemRef_vec(j) = LocalMemReference(pFIO_REAL32,[0]) + call c_f_pointer(lMemRef_vec(j)%base_address, gvar_1d, shape=[0]) + end if + call oClients%collective_stage_data(arrdes%collection_id(j), trim(fname_by_writer), name, lMemRef_vec(j), start=[1], & + global_start=[1], global_count=[size_1d]) + enddo + else + call oClients%collective_stage_data(arrdes%collection_id(1), trim(arrdes%filename), name, lMemRef, start=[1], & + global_start=[1], global_count=[size_1d]) + end if else if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then @@ -405,6 +424,7 @@ subroutine MAPL_FieldWriteNCPar(formatter, name, FIELD, ARRDES, HomePE, oClients call ArrayGather(vr8_1d, gvr8_1d, grid, mask=mask, rc=status) endif if (dims == MAPL_DimsVertOnly .and. arrdes%split_checkpoint) then + allocate(lMemRef_vec(arrdes%num_writers)) do j=1,arrdes%num_writers fname_by_writer = get_fname_by_rank(trim(arrdes%filename),j-1) if (mapl_am_i_root()) then @@ -1604,15 +1624,15 @@ subroutine MAPL_VarWriteNCpar_R4_1d(formatter, name, A, layout, ARRDES, MASK, of call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) _VERIFY(STATUS) - if (io_rank == 0) then + if (io_rank == 0 .or. arrdes%split_checkpoint) then call formatter%put_var(trim(name),A,start=start,count=cnt,rc=status) if(status /= NF90_NOERR) then print*,trim(IAm),'Error writing variable ',status print*, NF90_STRERROR(status) _VERIFY(STATUS) endif - endif ! io_rank = 0 - endif ! arrdes%writers_comm/=MPI_COMM_NULL + endif ! io_rank + endif else ! not present(arrdes) ! WY notes : it doesnot seem to get this branch call formatter%put_var(trim(name),A,start=start,count=cnt,rc=status) @@ -4138,13 +4158,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) endif arrdes%filename = trim(filename) enddo - if (arrdes%writers_comm /= mpi_comm_null) then - call mpi_comm_rank(arrdes%writers_comm,writer_rank,status) - _VERIFY(STATUS) - if (writer_rank == 0) then - call create_control_file(filename,arrdes%im_world,arrdes%num_writers,rc) - end if - end if else if (.not.allocated(arrdes%collection_id)) allocate(arrdes%collection_id(1)) iter = RstCollections%find(trim(BundleName)) @@ -4174,9 +4187,6 @@ subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, oClients, rc) fname_by_writer = get_fname_by_rank(trim(filename),writer_rank) call formatter%create(trim(fname_by_writer),rc=status) _VERIFY(status) - if (writer_rank == 0) then - call create_control_file(filename,arrdes%im_world,arrdes%num_writers,rc) - end if call cf%add_attribute("Split_Cubed_Sphere", writer_rank, _RC) else call formatter%create_par(trim(filename),comm=arrdes%writers_comm,info=info,rc=status) @@ -4295,28 +4305,6 @@ subroutine add_fvar(cf,vname,vtype,dims,units,long_name,rc) end subroutine add_fvar - subroutine create_control_file(filename,jm_world,num_writers,rc) - character(len=*), intent(in) :: filename - integer, intent(in) :: jm_world - integer, intent(in) :: num_writers - integer, intent(out), optional :: rc - integer :: status - type(ESMF_HConfig) :: hconfig - character(len=5) :: resolution - character(len=3) :: writers - character(len=:), allocatable :: yaml_content - - _ASSERT(jm_world < 10**5, 'Format not wide enough') - write(resolution,'(I5)')jm_world - _ASSERT(num_writers < 10**3, 'Format not wide enough') - write(writers,'(I3)')num_writers - yaml_content = "{j_size: "//trim(resolution)//", num_files: "//trim(writers)//"}" - hconfig = ESMF_HConfigCreate(content=yaml_content,_RC) - call ESMF_HConfigFileSave(hconfig,trim(filename),_RC) - _RETURN(_SUCCESS) - - end subroutine - end subroutine MAPL_BundleWriteNCPar subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWriteNoRestart, oClients, RC) diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index fd92d7822f9a..ff9ae69215b7 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -1168,6 +1168,7 @@ subroutine set_checkpoint_restart_options(rc) integer :: num_readers, num_writers character(len=ESMF_MAXSTR) :: split_checkpoint + character(len=ESMF_MAXSTR) :: split_restart character(len=ESMF_MAXSTR) :: write_restart_by_oserver integer :: j @@ -1179,6 +1180,8 @@ subroutine set_checkpoint_restart_options(rc) default=1, _RC) call MAPL_GetResource( STATE, split_checkpoint, Label="SPLIT_CHECKPOINT:", & default='NO', _RC) + call MAPL_GetResource( STATE, split_restart, Label="SPLIT_RESTART:", & + default='NO', _RC) split_checkpoint = ESMF_UtilStringUpperCase(split_checkpoint,_RC) call MAPL_GetResource( STATE, write_restart_by_oserver, Label="WRITE_RESTART_BY_OSERVER:", & @@ -1199,6 +1202,9 @@ subroutine set_checkpoint_restart_options(rc) if (trim(split_checkpoint) == 'YES') then mygrid%split_checkpoint = .true. endif + if (trim(split_restart) == 'YES') then + mygrid%split_restart = .true. + endif _RETURN(ESMF_SUCCESS) end subroutine set_checkpoint_restart_options @@ -5926,7 +5932,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) character(len=MPI_MAX_INFO_VAL ) :: romio_cb_read logical :: bootstrapable logical :: restartRequired - logical :: nwrgt1 + logical :: nwrgt1, on_tiles character(len=ESMF_MAXSTR) :: rstBoot integer :: rstReq logical :: amIRoot @@ -5949,6 +5955,11 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _RETURN(ESMF_SUCCESS) end if + + call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) + _VERIFY(status) + on_tiles = IAND(ATTR, MAPL_AttrTile) /= 0 + FNAME = adjustl(FILENAME) bootstrapable = .false. @@ -5974,6 +5985,8 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) rstReq = 0 end if restartRequired = (rstReq /= 0) + call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) + _VERIFY(status) call ESMF_VmGetCurrent(vm, rc=status) _VERIFY(status) @@ -5982,25 +5995,25 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) nwrgt1 = (mpl%grid%num_readers > 1) - split_restart = .false. isNC4 = -100 + if (on_tiles) mpl%grid%split_restart = .false. if(INDEX(FNAME,'*') == 0) then if (AmIRoot) then - hconfig = ESMF_HConfigCreate(filename = trim(filename), rc=status) - if (status == ESMF_SUCCESS) then - _ASSERT(ESMF_HConfigIsDefined(hconfig,keyString="num_files"),"if input file is split must supply num_files") - num_files = ESMF_HConfigAsI4(hconfig,keystring="num_files",_RC) - split_restart = .true. - end if + !if (mpl%grid%split_restart) then + !hconfig = ESMF_HConfigCreate(filename = trim(filename), _RC) + !_ASSERT(ESMF_HConfigIsDefined(hconfig,keyString="num_files"),"if input file is split must supply num_files") + !num_files = ESMF_HConfigAsI4(hconfig,keystring="num_files",_RC) + !split_restart = .true. + !end if block character(len=:), allocatable :: fname_by_reader logical :: fexist integer :: i FileExists = .false. - if (split_restart) then + if (mpl%grid%split_restart) then FileExists = .true. - do i = 0,num_files-1 + do i = 0,mpl%grid%num_readers-1 fname_by_reader = get_fname_by_rank(trim(fname), i) inquire(FILE = trim(fname_by_reader), EXIST=fexist) FileExists = FileExists .and. fexist @@ -6023,13 +6036,13 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call MAPL_CommsBcast(vm,split_restart,n=1,ROOT=MAPL_Root,_RC) call MAPL_CommsBcast(vm, fileExists, n=1, ROOT=MAPL_Root, _RC) - call MAPL_CommsBcast(vm, isNC4, n=1, ROOT=MAPL_Root, _RC) - if (split_restart) then - call MAPL_CommsBcast(vm, num_files, n=1, ROOT=MAPL_Root, _RC) - call MAPL_CommsBcast(vm, split_restart, n=1, ROOT=MAPL_Root, _RC) - mpl%grid%num_readers = num_files - mpl%grid%split_restart = split_restart - end if + call MAPL_CommsBcast(vm, isNC4, n=1, ROOT=MAPL_Root, _RC) + !if (split_restart) then + !call MAPL_CommsBcast(vm, num_files, n=1, ROOT=MAPL_Root, _RC) + !call MAPL_CommsBcast(vm, split_restart, n=1, ROOT=MAPL_Root, _RC) + !mpl%grid%num_readers = num_files + !mpl%grid%split_restart = split_restart + !end if if (FileExists) then if (isNC4 == 0) then @@ -6075,9 +6088,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) call ESMF_GridGet(MPL%GRID%ESMFGRID, dimCount=dimCount, RC=status) _VERIFY(status) - call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) - _VERIFY(status) - TILE: if(IAND(ATTR, MAPL_AttrTile) /= 0) then + TILE: if (on_tiles) then _ASSERT(IAND(ATTR, MAPL_AttrGrid) == 0,'needs informative message') ! no hybrid allowed _ASSERT(MAPL_LocStreamIsAssociated(MPL%LOCSTREAM,RC=status),'needs informative message') @@ -6141,9 +6152,7 @@ subroutine MAPL_ESMFStateReadFromFile(STATE,CLOCK,FILENAME,MPL,HDR,RC) _FAIL('needs informative message') end if #endif - call ESMF_AttributeGet(STATE, NAME = "MAPL_GridTypeBits", VALUE=ATTR, RC=status) - _VERIFY(status) - PNC4_TILE: if(IAND(ATTR, MAPL_AttrTile) /= 0) then + PNC4_TILE: if (on_tiles) then _ASSERT(IAND(ATTR, MAPL_AttrGrid) == 0,'needs informative message') ! no hybrid allowed call ArrDescrSetNCPar(arrdes,MPL,tile=.TRUE.,num_readers=mpl%grid%num_readers,RC=status) _VERIFY(status) @@ -8472,7 +8481,7 @@ subroutine MAPL_GetResourceFromConfig_array(config, vals, label, unusable, defau _UNUSED_DUMMY(unusable) call MAPL_GetResource_config_array(config, vals, label, value_set, & - default = default, rc=status) + default = default, rc=status) ! FIXME: assertion that value_set (TRUE) or return a non-negative rc value. ! Instead, optional argument value_is_set should to the value of value_set, @@ -10960,8 +10969,8 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, call ArrDescrCreateReaderComm(arrdes,mpl%grid%comm,mpl%grid%num_readers,_RC) arrdes%iogathercomm = mpl%grid%comm arrdes%ioscattercomm = mpl%grid%comm - arrdes%split_restart = .false. - arrdes%split_checkpoint = .false. + arrdes%split_restart = .false. + arrdes%split_checkpoint = .false. else call MAPL_GridGet(mpl%grid%ESMFGRID,globalCellCountPerDim=CCPD,RC=status) _VERIFY(status) @@ -10989,7 +10998,7 @@ subroutine ArrDescrSetNCPar(ArrDes, MPL, tile, offset, num_readers, num_writers, call mpi_comm_rank(arrdes%ycomm,arrdes%myrow,status) arrdes%split_restart = mpl%grid%split_restart arrdes%split_checkpoint = mpl%grid%split_checkpoint - + endif call MAPL_GetResource(MPL, romio_cb_read, Label="ROMIO_CB_READ:", default="automatic", RC=status) _VERIFY(status) From 1a641ee2c8d3bb3fc33864db8fc7b0b23be5abae Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Sun, 25 Feb 2024 09:18:35 -0700 Subject: [PATCH 045/141] Skip swath, trajectory destroy_regen_grid when list(n)%end_alarm is active --- gridcomps/History/MAPL_HistoryGridComp.F90 | 6 ++++-- gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 | 2 +- gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 | 3 +-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index dfb0786a6e82..2253e547e871 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -3689,7 +3689,7 @@ subroutine Run ( gc, import, export, clock, rc ) ! swath only epoch_swath_regen_grid: do n=1,nlist if (index(trim(list(n)%output_grid_label), 'SwathGrid') > 0) then - if( ESMF_AlarmIsRinging ( Hsampler%alarm ) ) then + if( ESMF_AlarmIsRinging ( Hsampler%alarm ) .and. .not. ESMF_AlarmIsRinging(list(n)%end_alarm) ) then key_grid_label = list(n)%output_grid_label call Hsampler%destroy_rh_regen_ogrid ( key_grid_label, IntState%output_grids, list(n)%xsampler, _RC ) @@ -3725,7 +3725,9 @@ subroutine Run ( gc, import, export, clock, rc ) if( ESMF_AlarmIsRinging ( list(n)%trajectory%alarm ) ) then call list(n)%trajectory%append_file(current_time,_RC) call list(n)%trajectory%close_file_handle(_RC) - call list(n)%trajectory%destroy_rh_regen_LS (_RC) + if ( .not. ESMF_AlarmIsRinging(list(n)%end_alarm) ) then + call list(n)%trajectory%destroy_rh_regen_LS (_RC) + end if end if end if diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 index ab646a3ea0d3..44ae9194aa40 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -68,7 +68,7 @@ module HistoryTrajectoryMod type(ESMF_TimeInterval) :: obsfile_interval integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index - logical :: active + logical :: active ! case: when no obs. exist contains procedure :: initialize => initialize_ procedure :: create_variable => create_metadata_variable diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index d75ac1813399..dece22fdceb8 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -228,10 +228,9 @@ _ASSERT(j>0, '% is not found, template is wrong') traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) end do - + _RETURN(_SUCCESS) - 105 format (1x,a,2x,a) 106 format (1x,a,2x,i8) end procedure HistoryTrajectory_from_config From 93045047a0b5fa5123888ac117b2faf287775fc1 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 28 Feb 2024 14:13:42 -0500 Subject: [PATCH 046/141] add procedures to remove an attribute from a file metdata object and variable object in PFIO --- CHANGELOG.md | 1 + pfio/FileMetadata.F90 | 11 ++++++++++- pfio/Variable.F90 | 12 ++++++++++++ 3 files changed, 23 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a288e5807a2c..55796ff4f4c1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Added procedures to remove an attribute from a FileMetadata object and from a Variable object in PFIO - Add per-collection timer output for History - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files diff --git a/pfio/FileMetadata.F90 b/pfio/FileMetadata.F90 index b453fcbb30af..d90d7ede533a 100644 --- a/pfio/FileMetadata.F90 +++ b/pfio/FileMetadata.F90 @@ -44,6 +44,7 @@ module pFIO_FileMetadataMod procedure :: add_attribute_1d procedure :: get_attribute procedure :: has_attribute + procedure :: remove_attribute procedure :: get_variable procedure :: get_coordinate_variable @@ -87,7 +88,7 @@ function new_FileMetadata(unusable, dimensions, global, variables, order) result type (StringVector), optional, intent(in) :: order - + fmd%dimensions = StringIntegerMap() if (present(dimensions)) fmd%dimensions = dimensions @@ -235,6 +236,14 @@ logical function has_attribute(this, attr_name) end function has_attribute + subroutine remove_attribute(this, attr_name) + class (FileMetadata), target, intent(inout) :: this + character(len=*), intent(in) :: attr_name + + call this%global_var%remove_attribute(attr_name) + + end subroutine + function get_attributes(this, rc ) result(attributes) type (StringAttributeMap), pointer :: attributes diff --git a/pfio/Variable.F90 b/pfio/Variable.F90 index 326fbfbd27bd..ae6a5c7bcafb 100644 --- a/pfio/Variable.F90 +++ b/pfio/Variable.F90 @@ -43,6 +43,7 @@ module pFIO_VariableMod generic :: add_attribute => add_attribute_1d procedure :: add_attribute_0d procedure :: add_attribute_1d + procedure :: remove_attribute procedure :: add_const_value procedure :: get_chunksizes @@ -182,6 +183,17 @@ function get_attributes(this) result(attributes) end function get_attributes + subroutine remove_attribute(this,attr_name,rc) + class (Variable), target, intent(inout) :: this + character(len=*), intent(in) :: attr_name + integer, optional, intent(out) :: rc + type(StringAttributeMapIterator) :: iter + integer :: status + + iter = this%attributes%find(attr_name) + call this%attributes%erase(iter) + _RETURN(_SUCCESS) + end subroutine subroutine add_attribute_0d(this, attr_name, attr_value, rc) class (Variable), target, intent(inout) :: this From c366973d20bb323250eae3717c77f14e724809f6 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 1 Mar 2024 08:54:51 -0700 Subject: [PATCH 047/141] update --- .../History/Sampler/MAPL_EpochSwathMod.F90 | 34 +++++++++---------- .../Sampler/MAPL_StationSamplerMod.F90 | 18 +++++----- 2 files changed, 25 insertions(+), 27 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index ae42ac808963..dea8857d33c0 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -312,23 +312,25 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) !__ s3. destroy acc_bundle / output_bundle call ESMF_FieldBundleGet(sp%acc_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) + allocate(names(numVars),_STAT) call ESMF_FieldBundleGet(sp%acc_bundle,fieldNameList=names,_RC) do i=1,numVars call ESMF_FieldBundleGet(sp%acc_bundle,trim(names(i)),field=field,_RC) call ESMF_FieldDestroy(field,noGarbage=.true., _RC) enddo call ESMF_FieldBundleDestroy(sp%acc_bundle,noGarbage=.true.,_RC) - + deallocate(names) + call ESMF_FieldBundleGet(sp%output_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) + allocate(names(numVars),_STAT) call ESMF_FieldBundleGet(sp%output_bundle,fieldNameList=names,_RC) do i=1,numVars call ESMF_FieldBundleGet(sp%output_bundle,trim(names(i)),field=field,_RC) call ESMF_FieldDestroy(field,noGarbage=.true., _RC) enddo call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) - + deallocate(names) + _RETURN(ESMF_SUCCESS) end subroutine destroy_rh_regen_ogrid @@ -439,7 +441,7 @@ subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) if (allocated(this%metadata)) then deallocate (this%metadata) end if - allocate(this%metadata) + allocate(this%metadata,_STAT) call factory%append_metadata(this%metadata) if (present(vdata)) then this%vdata=vdata @@ -519,8 +521,7 @@ subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,n if (present(quantize_algorithm)) this%quantizeAlgorithm = quantize_algorithm if (present(quantize_level)) this%quantizeLevel = quantize_level if (present(chunking)) then - allocate(this%chunking,source=chunking,stat=status) - _VERIFY(status) + allocate(this%chunking,source=chunking,_STAT) end if if (present(itemOrder)) this%itemOrderAlphabetical = itemOrder if (present(write_collection_id)) this%write_collection_id=write_collection_id @@ -695,8 +696,7 @@ subroutine RegridScalar(this,itemName,rc) else allocate(ptr3d(0,0,0)) end if - allocate(ptr3d_inter(size(ptr3d,1),size(ptr3d,2),this%vdata%lm),stat=status) - _VERIFY(status) + allocate(ptr3d_inter(size(ptr3d,1),size(ptr3d,2),this%vdata%lm),_STAT) if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then call this%vdata%regrid_select_level(ptr3d,ptr3d_inter,rc=status) _VERIFY(status) @@ -822,8 +822,7 @@ subroutine RegridVector(this,xName,yName,rc) else allocate(xptr3d(0,0,0)) end if - allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),stat=status) - _VERIFY(status) + allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),_STAT) if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then call this%vdata%regrid_select_level(xptr3d,xptr3d_inter,rc=status) _VERIFY(status) @@ -847,8 +846,7 @@ subroutine RegridVector(this,xName,yName,rc) else allocate(yptr3d(0,0,0)) end if - allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),stat=status) - _VERIFY(status) + allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),_STAT) if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then call this%vdata%regrid_select_level(yptr3d,yptr3d_inter,rc=status) _VERIFY(status) @@ -962,7 +960,7 @@ subroutine alphabatize_variables(this,nfixedVars,rc) order = this%metadata%get_order(rc=status) _VERIFY(status) n = Order%size() - allocate(temp(nFixedVars+1:n)) + allocate(temp(nFixedVars+1:n),_STAT) do i=1,n v1 => order%at(i) if ( i > nFixedVars) temp(i)=trim(v1) @@ -1092,11 +1090,11 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) call ESMF_FieldBundleGet(this%output_bundle, grid=grid, _RC) call ESMF_GridGet(grid, localDECount=localDECount, dimCount=dimCount, _RC) - allocate ( LB(dimCount), UB(dimCount), exclusiveCount(dimCount) ) - allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ) + allocate ( LB(dimCount), UB(dimCount), exclusiveCount(dimCount) ,_STAT) + allocate ( compLB(dimCount), compUB(dimCount), compCount(dimCount) ,_STAT) - allocate ( j1(0:localDEcount-1) ) ! start - allocate ( j2(0:localDEcount-1) ) ! end + allocate ( j1(0:localDEcount-1) ,_STAT) ! start + allocate ( j2(0:localDEcount-1) ,_STAT) ! end _ASSERT ( localDEcount == 1, 'failed, due to localDEcount > 1') call MAPL_GridGetInterior(grid,ii1,iin,jj1,jjn) diff --git a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 index 43d87bffacfe..5257f94c375f 100644 --- a/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 +++ b/gridcomps/History/Sampler/MAPL_StationSamplerMod.F90 @@ -123,12 +123,12 @@ function new_StationSampler_readfile (filename,nskip_line, rc) result(sampler) if (ios==0) nstation=nstation+1 end do sampler%nstation=nstation - allocate(sampler%station_id(nstation)) - allocate(sampler%station_name(nstation)) - allocate(sampler%station_fullname(nstation)) - allocate(sampler%lons(nstation)) - allocate(sampler%lats(nstation)) - allocate(sampler%elevs(nstation)) + allocate(sampler%station_id(nstation), _STAT) + allocate(sampler%station_name(nstation), _STAT) + allocate(sampler%station_fullname(nstation), _STAT) + allocate(sampler%lons(nstation), _STAT) + allocate(sampler%lats(nstation), _STAT) + allocate(sampler%elevs(nstation), _STAT) rewind(unit) if (nskip>0) then @@ -278,7 +278,7 @@ subroutine add_metadata_route_handle (this,bundle,timeInfo,vdata,rc) !__ 2. filemetadata: extract field from bundle, add_variable ! call ESMF_FieldBundleGet(bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount)) + allocate (fieldNameList(fieldCount), _STAT) call ESMF_FieldBundleGet(bundle, fieldNameList=fieldNameList, _RC) do i=1, fieldCount var_name=trim(fieldNameList(i)) @@ -358,7 +358,7 @@ subroutine append_file(this,current_time,rc) !__ 2. put_var: ungridded_dim from src to dst [regrid] ! call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount)) + allocate (fieldNameList(fieldCount), _STAT) call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) do i=1, fieldCount xname=trim(fieldNameList(i)) @@ -387,7 +387,7 @@ subroutine append_file(this,current_time,rc) call ESMF_FieldGet(dst_field,farrayptr=p_dst_3d,_RC) call this%regridder%regrid(p_src_3d,p_dst_3d,_RC) if (mapl_am_i_root()) then - nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx)) + nx=size(p_dst_3d,1); nz=size(p_dst_3d,2); allocate(arr(nz, nx), _STAT) arr=reshape(p_dst_3d,[nz,nx],order=[2,1]) call this%formatter%put_var(xname,arr,& start=[1,1,this%obs_written],count=[nz,nx,1],_RC) From 4201f59c60493bb7c95723c98eee494a1a12f140 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 1 Mar 2024 10:23:55 -0700 Subject: [PATCH 048/141] Add allocate(X, _STAT) --- .../History/Sampler/MAPL_EpochSwathMod.F90 | 43 +++++++------ .../Sampler/MAPL_GeosatMaskMod_smod.F90 | 52 ++++++++-------- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 61 ++++++++++--------- 3 files changed, 78 insertions(+), 78 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index dea8857d33c0..a0b306826fc4 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -319,7 +319,7 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) call ESMF_FieldDestroy(field,noGarbage=.true., _RC) enddo call ESMF_FieldBundleDestroy(sp%acc_bundle,noGarbage=.true.,_RC) - deallocate(names) + deallocate(names,_STAT) call ESMF_FieldBundleGet(sp%output_bundle,fieldCount=numVars,_RC) allocate(names(numVars),_STAT) @@ -329,7 +329,7 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) call ESMF_FieldDestroy(field,noGarbage=.true., _RC) enddo call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) - deallocate(names) + deallocate(names,_STAT) _RETURN(ESMF_SUCCESS) @@ -539,14 +539,14 @@ subroutine set_default_chunking(this,rc) call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) _VERIFY(status) if (global_dim(1)*6 == global_dim(2)) then - allocate(this%chunking(5)) + allocate(this%chunking(5),_STAT) this%chunking(1) = global_dim(1) this%chunking(2) = global_dim(1) this%chunking(3) = 1 this%chunking(4) = 1 this%chunking(5) = 1 else - allocate(this%chunking(4)) + allocate(this%chunking(4),_STAT) this%chunking(1) = global_dim(1) this%chunking(2) = global_dim(2) this%chunking(3) = 1 @@ -565,8 +565,7 @@ subroutine check_chunking(this,lev_size,rc) integer :: status character(len=5) :: c1,c2 - call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,rc=status) - _VERIFY(status) + call MAPL_GridGet(this%output_grid,globalCellCountPerDim=global_dim,_RC) if (global_dim(1)*6 == global_dim(2)) then write(c2,'(I5)')global_dim(1) write(c1,'(I5)')this%chunking(1) @@ -694,7 +693,7 @@ subroutine RegridScalar(this,itemName,rc) call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) _VERIFY(status) else - allocate(ptr3d(0,0,0)) + allocate(ptr3d(0,0,0),_STAT) end if allocate(ptr3d_inter(size(ptr3d,1),size(ptr3d,2),this%vdata%lm),_STAT) if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then @@ -725,13 +724,13 @@ subroutine RegridScalar(this,itemName,rc) call MAPL_FieldGetPointer(field,ptr2d,rc=status) _VERIFY(status) else - allocate(ptr2d(0,0)) + allocate(ptr2d(0,0),_STAT) end if if (hasDE_out) then call MAPL_FieldGetPointer(OutField,outptr2d,rc=status) _VERIFY(status) else - allocate(outptr2d(0,0)) + allocate(outptr2d(0,0),_STAT) end if if (gridIn==gridOut) then outPtr2d=ptr2d @@ -752,14 +751,14 @@ subroutine RegridScalar(this,itemName,rc) call ESMF_FieldGet(field,farrayPtr=ptr3d,rc=status) _VERIFY(status) else - allocate(ptr3d(0,0,0)) + allocate(ptr3d(0,0,0),_STAT) end if end if if (hasDE_out) then call MAPL_FieldGetPointer(OutField,outptr3d,rc=status) _VERIFY(status) else - allocate(outptr3d(0,0,0)) + allocate(outptr3d(0,0,0),_STAT) end if if (gridIn==gridOut) then outPtr3d=Ptr3d @@ -820,7 +819,7 @@ subroutine RegridVector(this,xName,yName,rc) call ESMF_FieldGet(xfield,farrayPtr=xptr3d,rc=status) _VERIFY(status) else - allocate(xptr3d(0,0,0)) + allocate(xptr3d(0,0,0),_STAT) end if allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),_STAT) if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then @@ -844,7 +843,7 @@ subroutine RegridVector(this,xName,yName,rc) call ESMF_FieldGet(yfield,farrayPtr=yptr3d,rc=status) _VERIFY(status) else - allocate(yptr3d(0,0,0)) + allocate(yptr3d(0,0,0),_STAT) end if allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),_STAT) if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then @@ -877,8 +876,8 @@ subroutine RegridVector(this,xName,yName,rc) call MAPL_FieldGetPointer(yfield,yptr2d,rc=status) _VERIFY(status) else - allocate(xptr2d(0,0)) - allocate(yptr2d(0,0)) + allocate(xptr2d(0,0),_STAT) + allocate(yptr2d(0,0),_STAT) end if if (hasDE_in) then @@ -887,8 +886,8 @@ subroutine RegridVector(this,xName,yName,rc) call MAPL_FieldGetPointer(yOutField,youtptr2d,rc=status) _VERIFY(status) else - allocate(xoutptr2d(0,0)) - allocate(youtptr2d(0,0)) + allocate(xoutptr2d(0,0),_STAT) + allocate(youtptr2d(0,0),_STAT) end if @@ -905,7 +904,7 @@ subroutine RegridVector(this,xName,yName,rc) call MAPL_FieldGetPointer(xfield,xptr3d,rc=status) _VERIFY(status) else - allocate(xptr3d(0,0,0)) + allocate(xptr3d(0,0,0),_STAT) end if end if if (.not.associated(yptr3d)) then @@ -913,7 +912,7 @@ subroutine RegridVector(this,xName,yName,rc) call MAPL_FieldGetPointer(yfield,yptr3d,rc=status) _VERIFY(status) else - allocate(yptr3d(0,0,0)) + allocate(yptr3d(0,0,0),_STAT) end if end if @@ -923,8 +922,8 @@ subroutine RegridVector(this,xName,yName,rc) call MAPL_FieldGetPointer(yOutField,youtptr3d,rc=status) _VERIFY(status) else - allocate(xoutptr3d(0,0,0)) - allocate(youtptr3d(0,0,0)) + allocate(xoutptr3d(0,0,0),_STAT) + allocate(youtptr3d(0,0,0),_STAT) end if if (gridIn==gridOut) then @@ -989,7 +988,7 @@ subroutine alphabatize_variables(this,nfixedVars,rc) enddo call this%metadata%set_order(newOrder,rc=status) _VERIFY(status) - deallocate(temp) + deallocate(temp,_STAT) _RETURN(_SUCCESS) diff --git a/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 b/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 index 3013c4f313ef..6201f50e2754 100644 --- a/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_GeosatMaskMod_smod.F90 @@ -233,8 +233,8 @@ ydim_true = n2 xdim_red = n1 / this%thin_factor ydim_red = n2 / this%thin_factor - allocate (x (xdim_true) ) - allocate (y (xdim_true) ) + allocate (x (xdim_true), _STAT ) + allocate (y (xdim_true), _STAT ) call get_v1d_netcdf_R8_complete (fn, key_x, x, _RC) call get_v1d_netcdf_R8_complete (fn, key_y, y, _RC) @@ -252,7 +252,7 @@ end if end do end do - allocate (lons(nx), lats(nx)) + allocate (lons(nx), lats(nx), _STAT) nx = 0 do i=1, xdim_red do j=1, ydim_red @@ -323,7 +323,7 @@ obs_lons = lons_ds * MAPL_DEGREES_TO_RADIANS_R8 obs_lats = lats_ds * MAPL_DEGREES_TO_RADIANS_R8 nx = size ( lons_ds ) - allocate ( II(nx), JJ(nx) ) + allocate ( II(nx), JJ(nx), _STAT ) call MPI_Barrier(mpic, status) call MAPL_GetHorzIJIndex(nx,II,JJ,lonR8=obs_lons,latR8=obs_lats,grid=grid,_RC) call ESMF_VMBarrier (vm, _RC) @@ -369,11 +369,11 @@ if (farrayPtr(i,j)/=0) k=k+1 end do end do - allocate( mask(IM, JM)) + allocate( mask(IM, JM), _STAT) mask(1:IM, 1:JM) = abs(farrayPtr(1:IM, 1:JM)) this%npt_mask = k - allocate( this%index_mask(2,k) ) + allocate( this%index_mask(2,k), _STAT ) arr(1)=k call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=this%npt_mask_tot, & count=1, reduceflag=ESMF_REDUCE_SUM, _RC) @@ -403,8 +403,8 @@ staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lons_ptr, _RC) call ESMF_GridGetCoord (grid, coordDim=2, localDE=0, & staggerloc=ESMF_STAGGERLOC_CENTER, farrayPtr=lats_ptr, _RC) - deallocate (lons, lats) - allocate (lons(this%npt_mask), lats(this%npt_mask)) + deallocate (lons, lats, _STAT) + allocate (lons(this%npt_mask), lats(this%npt_mask), _STAT) do i=1, this%npt_mask ix=this%index_mask(1,i) jx=this%index_mask(2,i) @@ -415,16 +415,16 @@ iroot=0 if (mapl_am_i_root()) then - allocate (this%lons(this%npt_mask_tot), this%lats(this%npt_mask_tot)) + allocate (this%lons(this%npt_mask_tot), this%lats(this%npt_mask_tot), _STAT) else - allocate (this%lons(0), this%lats(0)) + allocate (this%lons(0), this%lats(0), _STAT) end if ! __ s4.2 find this%recvcounts / this%displs ! - allocate( this%recvcounts(npes), this%displs(npes) ) - allocate( recvcounts_loc(npes), displs_loc(npes) ) + allocate( this%recvcounts(npes), this%displs(npes), _STAT ) + allocate( recvcounts_loc(npes), displs_loc(npes), _STAT ) recvcounts_loc(:)=1 displs_loc(1)=0 do i=2, npes @@ -507,7 +507,7 @@ !__ 2. filemetadata: extract field from bundle, add_variable to metadata ! call ESMF_FieldBundleGet(this%bundle, fieldCount=fieldCount, _RC) - allocate (fieldNameList(fieldCount)) + allocate (fieldNameList(fieldCount), _STAT) call ESMF_FieldBundleGet(this%bundle, fieldNameList=fieldNameList, _RC) do i=1, fieldCount var_name=trim(fieldNameList(i)) @@ -540,7 +540,7 @@ call v%add_attribute('valid_range', (/-MAPL_UNDEF,MAPL_UNDEF/)) call this%metadata%add_variable(trim(var_name),v,_RC) end do - deallocate (fieldNameList) + deallocate (fieldNameList, _STAT) _RETURN(_SUCCESS) end procedure add_metadata @@ -580,23 +580,23 @@ iroot=0 nx = this%npt_mask nz = this%vdata%lm - allocate(p_dst_2d (nx)) - allocate(p_dst_3d (nx * nz)) + allocate(p_dst_2d (nx), _STAT) + allocate(p_dst_3d (nx * nz), _STAT) if (mapl_am_i_root()) then - allocate ( p_dst_2d_full (this%npt_mask_tot) ) - allocate ( p_dst_3d_full (this%npt_mask_tot * nz) ) + allocate ( p_dst_2d_full (this%npt_mask_tot), _STAT ) + allocate ( p_dst_3d_full (this%npt_mask_tot * nz), _STAT ) else - allocate ( p_dst_2d_full (0) ) - allocate ( p_dst_3d_full (0) ) + allocate ( p_dst_2d_full (0), _STAT ) + allocate ( p_dst_3d_full (0), _STAT ) end if - allocate( recvcounts_3d(npes), displs_3d(npes) ) + allocate( recvcounts_3d(npes), displs_3d(npes), _STAT ) recvcounts_3d(:) = nz * this%recvcounts(:) displs_3d(:) = nz * this%displs(:) !__ 1. put_var: time variable ! - allocate( rtimes(1) ) + allocate( rtimes(1), _STAT ) rtimes(1) = this%compute_time_for_current(current_time,_RC) ! rtimes: seconds since opening file if (mapl_am_i_root()) then call this%formatter%put_var('time',rtimes(1:1),& @@ -655,12 +655,12 @@ p_dst_3d_full, recvcounts_3d, displs_3d, MPI_REAL,& iroot, mpic, ierr ) if (mapl_am_i_root()) then - allocate(arr(nz, this%npt_mask_tot)) + allocate(arr(nz, this%npt_mask_tot), _STAT) arr=reshape(p_dst_3d_full,[nz,this%npt_mask_tot],order=[1,2]) call this%formatter%put_var(item%xname,arr,& start=[1,1,this%obs_written],count=[nz,this%npt_mask_tot,1],_RC) !note: lev,station,time - deallocate(arr) + deallocate(arr, _STAT) end if else _FAIL('grid2LS regridder: rank > 3 not implemented') @@ -694,7 +694,7 @@ call this%formatter%write(this%metadata,_RC) nx = size (this%lons) - allocate ( x(nx) ) + allocate ( x(nx), _STAT ) x(:) = this%lons(:) * MAPL_RADIANS_TO_DEGREES call this%formatter%put_var('longitude',x,_RC) x(:) = this%lats(:) * MAPL_RADIANS_TO_DEGREES @@ -738,7 +738,7 @@ class default _FAIL("Time unit must be character") end select - allocate ( esmf_time_1d(1), rtime_1d(1) ) + allocate ( esmf_time_1d(1), rtime_1d(1), _STAT ) esmf_time_1d(1)= current_time call time_ESMF_to_real ( rtime_1d, esmf_time_1d, datetime_units, _RC ) rtime = rtime_1d(1) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index dece22fdceb8..b94af7d763cc 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -120,7 +120,7 @@ call ESMF_ConfigGetDim(config, nline, col, label=trim(string)//'obs_files:', rc=rc) _ASSERT(rc==0 .AND. nline > 0, 'obs_files not found') !! write(6,*) 'nline, col', nline, col - allocate(ncol(1:nline)) + allocate(ncol(1:nline), _STAT) call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC ) do i = 1, nline @@ -148,7 +148,7 @@ ! _FAIL('this setting in HISTORY.rc obs_files: is not supported, stop') traj%nobs_type = nline ! here .rc format cannot have empty spaces - allocate (traj%obs(nline)) + allocate (traj%obs(nline), _STAT) call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) do i=1, nline call ESMF_ConfigNextLine( config, tableEnd=tend, _RC) @@ -161,7 +161,7 @@ ! treatment-2: ! traj%nobs_type = nobs - allocate (traj%obs(nobs)) + allocate (traj%obs(nobs), _STAT) ! nobs=0 ! reuse counter head=1 @@ -175,7 +175,7 @@ call ESMF_ConfigNextLine(config, tableEnd=tend, _RC) M = ncol(i) _ASSERT(M>=1, '# of columns should be >= 1') - allocate (word(M)) + allocate (word(M), _STAT) count=0 do col=1, M call ESMF_ConfigGetAttribute(config, word(col), _RC) @@ -191,7 +191,7 @@ ! 3-item : var1 , 'root', var1_alias case STR1=trim(word(M)) end if - deallocate(word) + deallocate(word, _STAT) if ( index(trim(STR1), '-----') == 0 ) then if (head==1 .AND. trim(STR1)/='') then nobs=nobs+1 @@ -213,9 +213,9 @@ end if do k=1, traj%nobs_type - allocate (traj%obs(k)%metadata) + allocate (traj%obs(k)%metadata, _STAT) if (mapl_am_i_root()) then - allocate (traj%obs(k)%file_handle) + allocate (traj%obs(k)%file_handle, _STAT) end if end do @@ -265,9 +265,9 @@ else if (reinitialize) then do k=1, this%nobs_type - allocate (this%obs(k)%metadata) + allocate (this%obs(k)%metadata, _STAT) if (mapl_am_i_root()) then - allocate (this%obs(k)%file_handle) + allocate (this%obs(k)%file_handle, _STAT) end if end do !if (mapl_am_i_root()) write(6,'(2x,a,10(2x,L5))') & @@ -778,13 +778,13 @@ do k=1, this%nobs_type nx2 = this%obs(k)%nobs_epoch - allocate (this%obs(k)%lons(nx2)) - allocate (this%obs(k)%lats(nx2)) - allocate (this%obs(k)%times_R8(nx2)) - allocate (this%obs(k)%location_index_ioda(nx2)) + allocate (this%obs(k)%lons(nx2), _STAT) + allocate (this%obs(k)%lats(nx2), _STAT) + allocate (this%obs(k)%times_R8(nx2), _STAT) + allocate (this%obs(k)%location_index_ioda(nx2), _STAT) enddo - allocate(ix(this%nobs_type)) + allocate(ix(this%nobs_type), _STAT) ix(:)=0 j=this%epoch_index(1) do i=1, nx @@ -799,8 +799,8 @@ !endif j=j+1 enddo - deallocate(ix) - deallocate(lons_full, lats_full, times_R8_full, obstype_id_full, location_index_ioda_full) + deallocate(ix, _STAT) + deallocate(lons_full, lats_full, times_R8_full, obstype_id_full, location_index_ioda_full, _STAT) call lgr%debug('%a %i12 %i12 %i12', & 'epoch_index(1:2), nx', this%epoch_index(1), & @@ -937,10 +937,10 @@ ie=this%epoch_index(2)-this%epoch_index(1)+1 do k=1, this%nobs_type nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p2d(nx)) + allocate (this%obs(k)%p2d(nx), _STAT) enddo - allocate(ix(this%nobs_type)) + allocate(ix(this%nobs_type), _STAT) ix(:)=0 do j=is, ie k = this%obstype_id(j) @@ -955,7 +955,7 @@ _FAIL('test ix(k) failed') endif enddo - deallocate(ix) + deallocate(ix, _STAT) do k=1, this%nobs_type is = 1 nx = this%obs(k)%nobs_epoch @@ -969,7 +969,7 @@ endif enddo do k=1, this%nobs_type - deallocate (this%obs(k)%p2d) + deallocate (this%obs(k)%p2d, _STAT) enddo end if else if (rank==2) then @@ -999,16 +999,16 @@ ie=this%epoch_index(2)-this%epoch_index(1)+1 do k=1, this%nobs_type nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2))) + allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2)), _STAT) enddo - allocate(ix(this%nobs_type)) + allocate(ix(this%nobs_type), _STAT) ix(:)=0 do j=is, ie k = this%obstype_id(j) ix(k) = ix(k) + 1 this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) enddo - deallocate(ix) + deallocate(ix, _STAT) do k=1, this%nobs_type is = 1 nx = this%obs(k)%nobs_epoch @@ -1027,7 +1027,7 @@ !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) !! do k=1, this%nobs_type - deallocate (this%obs(k)%p3d) + deallocate (this%obs(k)%p3d, _STAT) enddo end if endif @@ -1179,12 +1179,12 @@ call this%locstream_factory%destroy_locstream(this%LS_ds, _RC) call this%regridder%destroy(_RC) deallocate (this%lons, this%lats, & - this%times_R8, this%obstype_id, this%location_index_ioda) + this%times_R8, this%obstype_id, this%location_index_ioda, _STAT) do k=1, this%nobs_type - deallocate (this%obs(k)%metadata) + deallocate (this%obs(k)%metadata, _STAT) if (mapl_am_i_root()) then - deallocate (this%obs(k)%file_handle) + deallocate (this%obs(k)%file_handle, _STAT) end if end do @@ -1212,23 +1212,24 @@ end if call ESMF_FieldBundleGet(this%acc_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) + allocate(names(numVars), _STAT) call ESMF_FieldBundleGet(this%acc_bundle,fieldNameList=names,_RC) do i=1,numVars call ESMF_FieldBundleGet(this%acc_bundle,trim(names(i)),field=field,_RC) call ESMF_FieldDestroy(field,noGarbage=.true., _RC) enddo call ESMF_FieldBundleDestroy(this%acc_bundle,noGarbage=.true.,_RC) + deallocate(names, _STAT) call ESMF_FieldBundleGet(this%output_bundle,fieldCount=numVars,_RC) - allocate(names(numVars),stat=status) + allocate(names(numVars), _STAT) call ESMF_FieldBundleGet(this%output_bundle,fieldNameList=names,_RC) do i=1,numVars call ESMF_FieldBundleGet(this%output_bundle,trim(names(i)),field=field,_RC) call ESMF_FieldDestroy(field,noGarbage=.true., _RC) enddo call ESMF_FieldBundleDestroy(this%output_bundle,noGarbage=.true.,_RC) - + deallocate(names, _STAT) call ESMF_ClockGet ( this%clock, CurrTime=currTime, _RC ) if (currTime > this%obsfile_end_time) then From 4308ed1e10a865ff9475157a70e5ed56bb8fde7e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 4 Mar 2024 14:46:12 -0500 Subject: [PATCH 049/141] Update to Baselibs 7.18.1 --- CHANGELOG.md | 4 ++++ components.yaml | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 55796ff4f4c1..01e9e6600cf9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added + - Added procedures to remove an attribute from a FileMetadata object and from a Variable object in PFIO - Add per-collection timer output for History - Add python utilities to split and recombine restarts @@ -17,6 +18,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed - Bypassed the I-Server reading call when there is no extdata +- Update `components.yaml` + - ESMA_env v4.27.0 (Baselibs 7.18.1) + - Moves to HDF5 1.14.3 ### Fixed diff --git a/components.yaml b/components.yaml index 4c63d816dee8..be466002a3c0 100644 --- a/components.yaml +++ b/components.yaml @@ -5,7 +5,7 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.24.0 + tag: v4.27.0 develop: main ESMA_cmake: From 746f12e2e9fe6b5a6e8d352bcce9965763138267 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 4 Mar 2024 14:46:43 -0500 Subject: [PATCH 050/141] Update to ESMA_cmake v3.41.0 --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index be466002a3c0..67c03eaaab00 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.40.0 + tag: v3.41.0 develop: develop ecbuild: From 5c1c1248cb11c9acee129c36ceff848cf99299b3 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 4 Mar 2024 14:48:17 -0500 Subject: [PATCH 051/141] Update changelog --- CHANGELOG.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 01e9e6600cf9..6f1c5c44f76a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -21,6 +21,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Update `components.yaml` - ESMA_env v4.27.0 (Baselibs 7.18.1) - Moves to HDF5 1.14.3 + - ESMA_cmake v3.41.0 + - Updates to MPI detection ### Fixed From 8c288f35ef7a8aa550a818caaa61dbddeb200b92 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 4 Mar 2024 16:22:50 -0500 Subject: [PATCH 052/141] update changelog --- Apps/combine_restarts.py | 23 ++++++++++------------- Apps/split_restart.py | 13 ++++--------- CHANGELOG.md | 3 ++- base/NCIO.F90 | 2 +- generic/MAPL_Generic.F90 | 3 +++ 5 files changed, 20 insertions(+), 24 deletions(-) diff --git a/Apps/combine_restarts.py b/Apps/combine_restarts.py index f92ee0d25122..ef39f690197f 100755 --- a/Apps/combine_restarts.py +++ b/Apps/combine_restarts.py @@ -11,6 +11,7 @@ def parse_args(): p = argparse.ArgumentParser(description='Flatten a lat-lon to 1D') p.add_argument('input',type=str,help='input file',default=None) + p.add_argument('nfiles',type=int,help='number of files',default=None) p.add_argument('output',type=str,help='output file',default=None) return vars(p.parse_args()) @@ -19,19 +20,15 @@ def parse_args(): #------------------ comm_args = parse_args() Input_template = comm_args['input'] +num_files = comm_args['nfiles'] Output_file = comm_args['output'] -f = open(Input_template,'r') -input_yaml = yaml.safe_load(f) -f.close() -num_files = input_yaml['num_files'] -j_size = input_yaml['j_size'] - -j_per_file = j_size*6//num_files ncFid = Dataset(Input_template+"_"+str(1), mode='r') ncFidOut = Dataset(Output_file, mode='w', format='NETCDF4') +res = len(ncFid.dimensions['lon']) +j_per_file = res*6//num_files #--------------------- # Extracting variables #--------------------- @@ -62,7 +59,7 @@ def parse_args(): for att in ncFid.variables['time'].ncattrs(): setattr(ncFidOut.variables['time'],att,getattr(ncFid.variables['time'],att)) new_time[:] = 0 - + vXdim = ncFidOut.createVariable('lon','f8',('lon')) vYdim = ncFidOut.createVariable('lat','f8',('lat')) @@ -72,7 +69,7 @@ def parse_args(): setattr(ncFidOut.variables['lat'],'long_name','latitude') vXdim[:]=range(1,cube_res+1) vYdim[:]=range(1,(cube_res*6)+1) - + for dim in detected_dims: if dim in ncFid.variables: vLevOut = ncFidOut.createVariable(dim,'f8',(dim)) @@ -104,7 +101,7 @@ def parse_args(): dim_size =len(temp.shape) float_type = ncFid.variables[var].dtype var_dims = ncFid.variables[var].dimensions - + if dim_size == 4: tout = ncFidOut.createVariable(var,float_type,var_dims,fill_value=1.0e15,chunksizes=(1,1,cube_res,cube_res)) for att in ncFid.variables[var].ncattrs(): @@ -115,7 +112,7 @@ def parse_args(): for att in ncFid.variables[var].ncattrs(): if att != "_FillValue": setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) - elif dim_size == 2: + elif dim_size == 2: tout = ncFidOut.createVariable(var,float_type,('lat','lon'),fill_value=1.0e15,chunksizes=(cube_res,cube_res)) for att in ncFid.variables[var].ncattrs(): if att != "_FillValue": @@ -131,13 +128,13 @@ def parse_args(): il = j_per_file*i iu = j_per_file*(i+1) ncFidOut.variables[var][:,:,il:iu,:] = temp[:,:,:,:] - + elif dim_size == 3: il = j_per_file*i iu = j_per_file*(i+1) ncFidOut.variables[var][:,il:iu,:] = temp[:,:,:] - elif dim_size == 2: + elif dim_size == 2: il = j_per_file*i iu = j_per_file*(i+1) ncFidOut.variables[var][il:iu,:] = temp[:,:] diff --git a/Apps/split_restart.py b/Apps/split_restart.py index 97468a6ac584..4c790395904b 100755 --- a/Apps/split_restart.py +++ b/Apps/split_restart.py @@ -50,11 +50,6 @@ def parse_args(): y_size = cube_res*6//n_files -# create master file -f = open(Output_template,mode='w') -out_master = "num_files: "+str(n_files)+"\n"+"j_size: "+str(cube_res) -f.write(out_master) -f.close() # create each file for i in range(n_files): ncFidOut = Dataset(Output_template+"_"+str(i), mode='w',format='NETCDF4') @@ -77,7 +72,7 @@ def parse_args(): for att in ncFid.variables['time'].ncattrs(): setattr(ncFidOut.variables['time'],att,getattr(ncFid.variables['time'],att)) new_time[:] = 0 - + vXdim = ncFidOut.createVariable('lon','f8',('lon')) vYdim = ncFidOut.createVariable('lat','f8',('lat')) @@ -124,7 +119,7 @@ def parse_args(): for att in ncFid.variables[var].ncattrs(): if att != "_FillValue": setattr(ncFidOut.variables[var],att,getattr(ncFid.variables[var],att)) - elif dim_size == 2: + elif dim_size == 2: tout = ncFidOut.createVariable(var,float_type,('lat','lon'),fill_value=1.0e15,chunksizes=(cube_res,cube_res)) for att in ncFid.variables[var].ncattrs(): if att != "_FillValue": @@ -135,7 +130,7 @@ def parse_args(): temp = ncFid.variables[var][:] dim_size =len(temp.shape) tout = ncFidOut.variables[var][:] - + if dim_size == 4: il = y_size*i iu = y_size*(i+1) @@ -146,7 +141,7 @@ def parse_args(): iu = y_size*(i+1) ncFidOut.variables[var][:,:,:] = temp[:,il:iu,:] - elif dim_size == 2: + elif dim_size == 2: il = y_size*i iu = y_size*(i+1) ncFidOut.variables[var][:,:] = temp[il:iu,:] diff --git a/CHANGELOG.md b/CHANGELOG.md index 55796ff4f4c1..b360d8985b80 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,7 +11,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Added procedures to remove an attribute from a FileMetadata object and from a Variable object in PFIO - Add per-collection timer output for History - Add python utilities to split and recombine restarts -- Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files +- Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer - Implemented a new algorthm to read tile files ### Changed @@ -20,6 +20,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Fixed bug with split restart files - Removed unnecessary memory allocation for tile reads. This is critical for high res runs on SCU17 - Fixes to allow SCM model to run diff --git a/base/NCIO.F90 b/base/NCIO.F90 index 35037294b65c..928566cadc4e 100644 --- a/base/NCIO.F90 +++ b/base/NCIO.F90 @@ -1279,7 +1279,7 @@ subroutine MAPL_VarReadNCpar_R4_2d(formatter, name, A, ARRDES, lev, offset2, RC) cnt(3) = 1 cnt(4) = 1 - if(arrdes%split_checkpoint) then + if(arrdes%split_restart) then start(2) = 1 endif diff --git a/generic/MAPL_Generic.F90 b/generic/MAPL_Generic.F90 index ff9ae69215b7..c7f59fa19977 100644 --- a/generic/MAPL_Generic.F90 +++ b/generic/MAPL_Generic.F90 @@ -1182,6 +1182,7 @@ subroutine set_checkpoint_restart_options(rc) default='NO', _RC) call MAPL_GetResource( STATE, split_restart, Label="SPLIT_RESTART:", & default='NO', _RC) + split_restart = ESMF_UtilStringUpperCase(split_restart,_RC) split_checkpoint = ESMF_UtilStringUpperCase(split_checkpoint,_RC) call MAPL_GetResource( STATE, write_restart_by_oserver, Label="WRITE_RESTART_BY_OSERVER:", & @@ -1199,6 +1200,8 @@ subroutine set_checkpoint_restart_options(rc) mygrid%comm = comm mygrid%num_readers = num_readers mygrid%num_writers = num_writers + mygrid%split_checkpoint = .false. + mygrid%split_restart = .false. if (trim(split_checkpoint) == 'YES') then mygrid%split_checkpoint = .true. endif From 9961a17146a11c0920f7ca9c631f566992248f14 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 4 Mar 2024 15:34:10 -0700 Subject: [PATCH 053/141] Add extract_unquoted_item(STR1) to fix a bug in geoval_xname(mx_ngeoval) --- base/MAPL_ObsUtil.F90 | 3 +- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 62 ++++++++++++++----- 2 files changed, 49 insertions(+), 16 deletions(-) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index c45749f0501b..17e41d718d71 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -31,7 +31,8 @@ module MAPL_ObsUtilMod character(len=ESMF_MAXSTR) :: name character(len=ESMF_MAXSTR) :: obsFile_output character(len=ESMF_MAXSTR) :: input_template - character(len=ESMF_MAXSTR) :: geoval_name(mx_ngeoval) + character(len=ESMF_MAXSTR) :: geoval_xname(mx_ngeoval) + character(len=ESMF_MAXSTR) :: geoval_yname(mx_ngeoval) real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: times_R8(:) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index b94af7d763cc..c2b213dd664b 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -42,9 +42,11 @@ integer :: nobs, head, jvar logical :: tend integer :: i, j, k, M - integer :: count + integer :: count, idx integer :: unitr, unitw - type(Logger), pointer :: lgr + type(GriddedIOitem) :: item + type(Logger), pointer :: lgr + traj%clock=clock call ESMF_ClockGet ( clock, CurrTime=currTime, _RC ) @@ -126,7 +128,7 @@ do i = 1, nline call ESMF_ConfigNextLine(config, _RC) ncol(i) = ESMF_ConfigGetLen(config, _RC) - !!write(6,*) 'line', i, 'ncol(i)', ncol(i) +!! write(6,*) 'line', i, 'ncol(i)', ncol(i) enddo @@ -178,9 +180,10 @@ allocate (word(M), _STAT) count=0 do col=1, M - call ESMF_ConfigGetAttribute(config, word(col), _RC) - if (trim(word(col))/=',') then + call ESMF_ConfigGetAttribute(config, STR1, _RC) + if (trim(STR1)/=',') then count=count+1 + word(count) = extract_unquoted_item(STR1) end if enddo if (count ==1 .or. count==2) then @@ -189,7 +192,7 @@ STR1=trim(word(1)) else ! 3-item : var1 , 'root', var1_alias case - STR1=trim(word(M)) + STR1=trim(word(3)) end if deallocate(word, _STAT) if ( index(trim(STR1), '-----') == 0 ) then @@ -201,7 +204,13 @@ else if (trim(STR1)/='') then jvar=jvar+1 - traj%obs(nobs)%geoval_name(jvar) = trim(STR1) + idx = index(STR1,";") + if (idx==0) then + traj%obs(nobs)%geoval_xname(jvar) = STR1 + else + traj%obs(nobs)%geoval_xname(jvar) = trim(STR1(1:idx-1)) + traj%obs(nobs)%geoval_yname(jvar) = trim(STR1(idx+1:)) + end if end if end if else @@ -228,7 +237,7 @@ _ASSERT(j>0, '% is not found, template is wrong') traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) end do - + _RETURN(_SUCCESS) 105 format (1x,a,2x,a) @@ -387,12 +396,12 @@ do k = 1, this%nobs_type do ig = 1, this%obs(k)%ngeoval - if (trim(var_name) == trim(this%obs(k)%geoval_name(ig))) then + if (trim(var_name) == trim(this%obs(k)%geoval_xname(ig))) then call this%obs(k)%metadata%add_variable(trim(var_name),v,_RC) !! if (mapl_am_i_root()) write(6, '(2x,a,/,10(2x,a))') & -!! 'Traj: create_metadata_variable: vname, var_name, this%obs(k)%geoval_name(ig)', & -!! trim(vname), trim(var_name), trim(this%obs(k)%geoval_name(ig)) +!! 'Traj: create_metadata_variable: vname, var_name, this%obs(k)%geoval_xname(ig)', & +!! trim(vname), trim(var_name), trim(this%obs(k)%geoval_xname(ig)) endif @@ -920,12 +929,11 @@ iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() - if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'item%xname', trim(item%xname) - if (item%itemType == ItemTypeScalar) then call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) call ESMF_FieldGet(acc_field,rank=rank,_RC) if (rank==1) then +!! if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:2d item%xname', trim(item%xname) call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC) call ESMF_FieldGet( acc_field_2d_rt, localDE=0, farrayPtr=p_acc_rt_2d, _RC) call ESMF_FieldRedist( acc_field, acc_field_2d_rt, RH, _RC) @@ -961,7 +969,9 @@ nx = this%obs(k)%nobs_epoch if (nx>0) then do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then + !!write(6,'(2x,a,2x,a)') 't this%obs(k)%geoval_xname(ig)', trim(this%obs(k)%geoval_xname(ig)) + if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then + !!write(6, '(2x,a,2x,a)') 'append:2d inner put_var item%xname', trim(item%xname) call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & start=[is],count=[nx]) end if @@ -973,6 +983,7 @@ enddo end if else if (rank==2) then + !!if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:3d item%xname', trim(item%xname) call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) call ESMF_FieldGet( acc_field_3d_rt, localDE=0, farrayPtr=p_acc_rt_3d, _RC) @@ -1014,7 +1025,8 @@ nx = this%obs(k)%nobs_epoch if (nx>0) then do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_name(ig))) then + if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then + !!write(6, '(2x,a,2x,a)') 'append:3d inner put_var item%xname', trim(item%xname) call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) end if @@ -1289,4 +1301,24 @@ end procedure get_x_subset + function extract_unquoted_item(string_list) result(item) + character(:), allocatable :: item + character(*), intent(in) :: string_list + + integer :: i + integer :: j + + character(1) :: QUOTE = "'" + + i = index(string_list( 1:), QUOTE) + j = index(string_list(i+1:), QUOTE)+i + if( i.ne.0 ) then + item = adjustl( string_list(i+1:j-1) ) + else + item = adjustl( string_list) + endif + end function extract_unquoted_item + + + end submodule HistoryTrajectory_implement From 21a6e208c9650669787e368c93c459602d44c88c Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 5 Mar 2024 09:12:57 -0700 Subject: [PATCH 054/141] add items to changelog.md --- CHANGELOG.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 98a2b63d72f5..9395aa82a967 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Add mask sampler for geostationary satellite (GEOS-R series) - Add geostation name into NC for station sampler - Add mapping between the IODA loc_index and trajectory NC output loc_index +- Add allocate(X, _STAT) to sampler codes +- Skip destroy_regen_grid when list(n)%end_alarm is active (the last time step in sampler) +- Add extract_unquoted_item(STR1) to fix a bug in geoval_xname(mx_ngeoval) in trajectory sampler - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files - implemented a new algorthm to read tile files From 0fbcd5c75171cb4446eafe296860cc6b66534937 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 6 Mar 2024 08:39:21 -0500 Subject: [PATCH 055/141] fixes and improvements to the per-file writing --- base/MAPL_EsmfRegridder.F90 | 49 ++++++++++++++++------- gridcomps/ExtData2G/ExtDataGridCompNG.F90 | 46 ++++++++++++--------- griddedio/GriddedIO.F90 | 8 +++- 3 files changed, 68 insertions(+), 35 deletions(-) diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 02e997539293..7d0e38ce4604 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -1440,7 +1440,7 @@ subroutine create_route_handle(this, kind, rc) type(RegridderSpecRouteHandleMap), pointer :: route_handles, transpose_route_handles type(ESMF_RouteHandle) :: route_handle, transpose_route_handle character(len=ESMF_MAXPATHLEN) :: rh_file,rh_trans_file - logical :: rh_file_exists + logical :: rh_file_exists, file_weights, compute_transpose if (kind == ESMF_TYPEKIND_R4) then route_handles => route_handles_r4 @@ -1457,14 +1457,23 @@ subroutine create_route_handle(this, kind, rc) spec = this%get_spec() if (route_handles%count(spec) == 0) then ! new route_handle - rh_file = generate_rh_name(spec%grid_in,spec%grid_out,_RC) + file_weights = IAND(spec%hints,REGRID_HINT_FILE_WEIGHTS) /= 0 + compute_transpose = IAND(spec%hints,REGRID_HINT_COMPUTE_TRANSPOSE) /= 0 + rh_file = generate_rh_name(spec%grid_in,spec%grid_out,spec%regrid_method,_RC) rh_trans_file = "transpose_"//rh_file - inquire(file=rh_file,exist=rh_file_exists) + + if (file_weights) then + inquire(file=rh_file,exist=rh_file_exists) + else + rh_file_exists = .false. + end if if (rh_file_exists) then route_handle = ESMF_RouteHandleCreate(rh_file,_RC) - transpose_route_handle = ESMF_RouteHandleCreate(rh_trans_file,_RC) call route_handles%insert(spec, route_handle) - call transpose_route_handles%insert(spec, transpose_route_handle) + if (compute_transpose) then + transpose_route_handle = ESMF_RouteHandleCreate(rh_trans_file,_RC) + call transpose_route_handles%insert(spec, transpose_route_handle) + end if else src_field = ESMF_FieldCreate(spec%grid_in, typekind=kind, & & indexflag=ESMF_INDEX_DELOCAL, staggerloc=ESMF_STAGGERLOC_CENTER, rc=status) @@ -1557,13 +1566,16 @@ subroutine create_route_handle(this, kind, rc) case default _FAIL('unknown regrid method') end select - call ESMF_FieldSMMStore(src_field,dst_field,dummy_rh,transpose_route_handle, & - & factorList,factorIndexList,srcTermProcessing=srcTermProcessing, & - & rc=status) - _VERIFY(status) - call route_handles%insert(spec, route_handle) - call transpose_route_handles%insert(spec, transpose_route_handle) + + if (compute_transpose) then + call ESMF_FieldSMMStore(src_field,dst_field,dummy_rh,transpose_route_handle, & + & factorList,factorIndexList,srcTermProcessing=srcTermProcessing, & + & rc=status) + _VERIFY(status) + call transpose_route_handles%insert(spec, transpose_route_handle) + end if + ! Free resources deallocate(factorList,factorIndexList) @@ -1571,8 +1583,12 @@ subroutine create_route_handle(this, kind, rc) _VERIFY(status) call ESMF_FieldDestroy(dst_field, rc=status) _VERIFY(status) - call ESMF_RouteHandleWrite(route_handle,rh_file,_RC) - call ESMF_RouteHandleWrite(transpose_route_handle,rh_trans_file,_RC) + if (file_weights) then + call ESMF_RouteHandleWrite(route_handle,rh_file,_RC) + if (compute_transpose) then + call ESMF_RouteHandleWrite(transpose_route_handle,rh_trans_file,_RC) + end if + end if end if end if @@ -1677,16 +1693,18 @@ subroutine destroy_route_handle(this, kind, rc) _RETURN(_SUCCESS) end subroutine destroy_route_handle - function generate_rh_name(grid_in,grid_out,rc) result(file_name) + function generate_rh_name(grid_in,grid_out,regrid_method,rc) result(file_name) character(len=:), allocatable :: file_name type(ESMF_Grid), intent(in) :: grid_in type(ESMF_Grid), intent(in) :: grid_out + integer, intent(in) :: regrid_method integer, intent(out), optional :: rc integer :: im_in, jm_in, im_out, jm_out integer :: nx_in, ny_in, nx_out, ny_out character(len=5) :: cim_in,cjm_in,cim_out,cjm_out character(len=5) :: cnx_in,cny_in,cnx_out,cny_out + character(len=2) :: cmeth integer :: temp(3),layout(2) integer :: status @@ -1708,7 +1726,8 @@ function generate_rh_name(grid_in,grid_out,rc) result(file_name) write(cjm_out,'(I5.5)')jm_out write(cnx_out,'(I5.5)')nx_out write(cny_out,'(I5.5)')ny_out - file_name = "rh_"//cim_in//"x"//cjm_in//"_"//cnx_in//"x"//cny_in//"_"//cim_out//"x"//cjm_out//"_"//cnx_out//"x"//cny_out + write(cmeth,'(I2.2)')regrid_method + file_name = "rh_"//cim_in//"x"//cjm_in//"_"//cnx_in//"x"//cny_in//"_"//cim_out//"x"//cjm_out//"_"//cnx_out//"x"//cny_out//"_method_"//cmeth _RETURN(_SUCCESS) end function diff --git a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 index 2a14407b4ced..44877d8f1552 100644 --- a/gridcomps/ExtData2G/ExtDataGridCompNG.F90 +++ b/gridcomps/ExtData2G/ExtDataGridCompNG.F90 @@ -107,7 +107,8 @@ MODULE MAPL_ExtDataGridComp2G !! needed by a derived field where the primary fields !! are not actually required type(ESMF_Config) :: CF - logical :: active + logical :: active = .true. + logical :: file_weights = .false. end type MAPL_ExtData_State ! Hook for the ESMF @@ -289,7 +290,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_TimerOn(MAPLSTATE,"Initialize") call ESMF_ConfigGetAttribute(cf_master,new_rc_file,label="EXTDATA_YAML_FILE:",default="extdata.yaml",_RC) - self%active = am_i_running(new_rc_file,_RC) + call get_global_options(new_rc_file,self%active,self%file_weights,_RC) call ESMF_ClockGet(CLOCK, currTIME=time, _RC) ! Get information from export state @@ -621,7 +622,7 @@ SUBROUTINE Run_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_TimerOff(MAPLSTATE,"---CreateCFIO") call MAPL_TimerOn(MAPLSTATE,"---prefetch") - call MAPL_ExtDataPrefetch(IOBundles, rc=status) + call MAPL_ExtDataPrefetch(IOBundles, file_weights=self%file_weights, rc=status) _VERIFY(status) call MAPL_TimerOff(MAPLSTATE,"---prefetch") _VERIFY(STATUS) @@ -1377,21 +1378,26 @@ subroutine MAPL_ExtDataDestroyCFIO(IOBundles,rc) end subroutine MAPL_ExtDataDestroyCFIO - subroutine MAPL_ExtDataPrefetch(IOBundles,rc) + subroutine MAPL_ExtDataPrefetch(IOBundles,file_weights,rc) type(IOBundleNGVector), target, intent(inout) :: IOBundles + logical, intent(in) :: file_weights integer, optional, intent(out ) :: rc - integer :: n,nfiles + integer :: n,nfiles,regrid_hints type(ExtDataNG_IOBundle), pointer :: io_bundle => null() integer :: status nfiles = IOBundles%size() + regrid_hints = 0 + if (file_weights) regrid_hints = IOR(regrid_hints,REGRID_HINT_FILE_WEIGHTS) + do n = 1, nfiles io_bundle => IOBundles%at(n) if (io_bundle%on_tiles) then call io_bundle%tile_io%request_data_from_file(io_bundle%file_name,io_bundle%time_index,_RC) else + call io_bundle%grid_io%set_param(regrid_hints=regrid_hints) call io_bundle%grid_io%request_data_from_file(io_bundle%file_name,io_bundle%time_index,_RC) end if enddo @@ -1777,22 +1783,26 @@ function get_item_index(this,base_name,current_time,rc) result(item_index) _RETURN(_SUCCESS) end function get_item_index - function am_i_running(yaml_file,rc) result(am_running) - logical :: am_running + subroutine get_global_options(yaml_file,am_running,use_file_weights,rc) character(len=*), intent(in) :: yaml_file + logical,intent(out) :: am_running + logical,intent(out) :: use_file_weights integer, intent(out), optional :: rc + type(ESMF_HConfig), allocatable :: config + integer :: status - type(ESMF_HConfig), allocatable :: config - integer :: status - - am_running=.true. - - config = ESMF_HConfigCreate(filename = trim(yaml_file),_RC) - if (ESMF_HConfigIsDefined(config,keyString="USE_EXTDATA")) then - am_running = ESMF_HConfigAsLogical(config,keyString="USE_EXTDATA",_RC) - end if - _RETURN(_SUCCESS) + am_running=.true. + use_file_weights=.false. + config = ESMF_HConfigCreate(filename = trim(yaml_file),_RC) + if (ESMF_HConfigIsDefined(config,keyString="USE_EXTDATA")) then + am_running = ESMF_HConfigAsLogical(config,keyString="USE_EXTDATA",_RC) + end if + if (ESMF_HConfigIsDefined(config,keyString="file_weights")) then + use_file_weights = ESMF_HConfigAsLogical(config,keyString="file_weights",_RC) + end if + call ESMF_HConfigDestroy(config) + _RETURN(_SUCCESS) + end subroutine get_global_options - end function am_i_running END MODULE MAPL_ExtDataGridComp2G diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index 2fa6bb522d89..c6349c4705e0 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -56,6 +56,7 @@ module MAPL_GriddedIOMod integer, allocatable :: chunking(:) logical :: itemOrderAlphabetical = .true. integer :: fraction + integer :: regrid_hints contains procedure :: CreateFileMetaData procedure :: CreateVariable @@ -234,7 +235,7 @@ subroutine destroy(this, rc) end subroutine destroy - subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,nbits_to_keep,regrid_method,itemOrder,write_collection_id,rc) + subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,nbits_to_keep,regrid_method,itemOrder,write_collection_id,regrid_hints,rc) class (MAPL_GriddedIO), intent(inout) :: this integer, optional, intent(in) :: deflation integer, optional, intent(in) :: quantize_algorithm @@ -244,6 +245,7 @@ subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,n integer, optional, intent(in) :: regrid_method logical, optional, intent(in) :: itemOrder integer, optional, intent(in) :: write_collection_id + integer, optional, intent(in) :: regrid_hints integer, optional, intent(out) :: rc integer :: status @@ -259,6 +261,7 @@ subroutine set_param(this,deflation,quantize_algorithm,quantize_level,chunking,n end if if (present(itemOrder)) this%itemOrderAlphabetical = itemOrder if (present(write_collection_id)) this%write_collection_id=write_collection_id + if (present(regrid_hints)) this%regrid_hints = regrid_hints _RETURN(ESMF_SUCCESS) end subroutine set_param @@ -1074,6 +1077,7 @@ subroutine request_data_from_file(this,filename,timeindex,rc) type(ESMF_Grid) :: output_grid logical :: hasDE class(AbstractGridFactory), pointer :: factory + integer :: regrid_hints collection => Datacollections%at(this%metadata_collection_id) this%current_file_metadata => collection%find(filename, _RC) @@ -1084,7 +1088,7 @@ subroutine request_data_from_file(this,filename,timeindex,rc) call ESMF_FieldBundleGet(this%output_bundle,grid=output_grid,rc=status) _VERIFY(status) if (filegrid/=output_grid) then - this%regrid_handle => new_regridder_manager%make_regridder(filegrid,output_grid,this%regrid_method,rc=status) + this%regrid_handle => new_regridder_manager%make_regridder(filegrid,output_grid,this%regrid_method,hints=this%regrid_hints,rc=status) _VERIFY(status) end if call MAPL_GridGet(filegrid,globalCellCountPerdim=dims,rc=status) From c9002c3aa4493d7399999a19cc09e25ce8b794b7 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 6 Mar 2024 08:39:53 -0500 Subject: [PATCH 056/141] forgot to commit file --- base/RegridMethods.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/base/RegridMethods.F90 b/base/RegridMethods.F90 index 33e8d23c3944..040ab30e1299 100644 --- a/base/RegridMethods.F90 +++ b/base/RegridMethods.F90 @@ -4,6 +4,8 @@ module mapl_RegridMethods private public :: REGRID_HINT_LOCAL + public :: REGRID_HINT_FILE_WEIGHTS + public :: REGRID_HINT_COMPUTE_TRANSPOSE public :: REGRID_METHOD_IDENTITY public :: REGRID_METHOD_BILINEAR public :: REGRID_METHOD_BILINEAR_MONOTONIC @@ -38,6 +40,8 @@ module mapl_RegridMethods end enum integer, parameter :: TILING_METHODS(3) = [REGRID_METHOD_CONSERVE,REGRID_METHOD_VOTE,REGRID_METHOD_FRACTION] integer, parameter :: REGRID_HINT_LOCAL = 1 + integer, parameter :: REGRID_HINT_FILE_WEIGHTS = 2 + integer, parameter :: REGRID_HINT_COMPUTE_TRANSPOSE = 4 contains From 9b0e06c540510577ecab70270a91dbb46eca8ea3 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 6 Mar 2024 12:00:50 -0500 Subject: [PATCH 057/141] add options for History weights --- gridcomps/History/MAPL_HistoryGridComp.F90 | 10 +++++++++- griddedio/GriddedIO.F90 | 2 +- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 8088a4c11421..96c53f6225e4 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -125,6 +125,7 @@ module MAPL_HistoryGridCompMod integer :: collectionWriteSplit integer :: serverSizeSplit logical :: allow_overwrite + logical :: file_weights end type HISTORY_STATE type HISTORY_wrap @@ -415,7 +416,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) character(len=:), pointer :: key type(StringFieldSetMapIterator) :: field_set_iter character(ESMF_MAXSTR) :: field_set_name - integer :: collection_id + integer :: collection_id, regrid_hints logical, allocatable :: needSplit(:) type(ESMF_Field), allocatable :: fldList(:) character(len=ESMF_MAXSTR), allocatable :: regexList(:) @@ -519,6 +520,8 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) label='FileOrder:', default='ABC', _RC) call ESMF_ConfigGetAttribute(config, value=intState%allow_overwrite, & label='Allow_Overwrite:', default=.false., _RC) + call ESMF_ConfigGetAttribute(config, value=intState%file_weights, & + label='file_weights:', default=.false., _RC) create_mode = PFIO_NOCLOBBER ! defaut no overwrite if (intState%allow_overwrite) create_mode = PFIO_CLOBBER @@ -2402,6 +2405,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call list(n)%mGriddedIO%set_param(nbits_to_keep=list(n)%nbits_to_keep,_RC) call list(n)%mGriddedIO%set_param(regrid_method=list(n)%regrid_method,_RC) call list(n)%mGriddedIO%set_param(itemOrder=intState%fileOrderAlphabetical,_RC) + if (intState%file_weights) then + regrid_hints = 0 + regrid_hints = IOR(regrid_hints,REGRID_HINT_FILE_WEIGHTS) + call list(n)%mGriddedIO%set_param(regrid_hints=regrid_hints,_RC) + end if if (list(n)%monthly) then nextMonth = currTime - oneMonth diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index c6349c4705e0..df2f3831aeb4 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -149,7 +149,7 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr _VERIFY(status) end if - this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,rc=status) + this%regrid_handle => new_regridder_manager%make_regridder(input_grid,this%output_grid,this%regrid_method,hints=this%regrid_hints,rc=status) _VERIFY(status) From c38ae0502986c6308ada29a3d3473c05e65db542 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 6 Mar 2024 14:30:17 -0500 Subject: [PATCH 058/141] update changelog --- CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index a288e5807a2c..d581dd6dbea9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Add option to MAPL regridding layer to write and retrieve ESMF weights. +- Add options to History and ExtData to turn on the ability to write and read route handle weights +- Add option to renable the transpose computation when calling make\_regridder - Add per-collection timer output for History - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer wit the base checkpoint name being a control file that tells how many files were written to. On reading if this control file is provided as the restart file name, it will automatically trigger reading the individual files @@ -15,6 +18,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- The MAPL\_ESMFRegridder manage now does compute the transpose by default - Bypassed the I-Server reading call when there is no extdata ### Fixed From 25e7b9f4617d71bf8f4340c0ce33c983a904d007 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 6 Mar 2024 14:38:42 -0500 Subject: [PATCH 059/141] remove unneccessary use --- base/MaplGrid.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/base/MaplGrid.F90 b/base/MaplGrid.F90 index 55eac264f433..d7b126683be3 100644 --- a/base/MaplGrid.F90 +++ b/base/MaplGrid.F90 @@ -7,7 +7,6 @@ module mapl_MaplGrid use MAPL_ErrorHandlingMod use MAPL_KeywordEnforcerMod use MAPL_ConstantsMod, only : MAPL_PI_R8, MAPL_UnitsRadians - use NetCDF implicit none private From e425404bed00c01f2ba3738b6263c7d766ed7879 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 6 Mar 2024 16:12:35 -0500 Subject: [PATCH 060/141] bug fix --- base/MAPL_EsmfRegridder.F90 | 4 ++-- base/MaplGrid.F90 | 6 ++++++ 2 files changed, 8 insertions(+), 2 deletions(-) diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 7d0e38ce4604..6ba2810d3ab2 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -1459,10 +1459,10 @@ subroutine create_route_handle(this, kind, rc) if (route_handles%count(spec) == 0) then ! new route_handle file_weights = IAND(spec%hints,REGRID_HINT_FILE_WEIGHTS) /= 0 compute_transpose = IAND(spec%hints,REGRID_HINT_COMPUTE_TRANSPOSE) /= 0 - rh_file = generate_rh_name(spec%grid_in,spec%grid_out,spec%regrid_method,_RC) - rh_trans_file = "transpose_"//rh_file if (file_weights) then + rh_file = generate_rh_name(spec%grid_in,spec%grid_out,spec%regrid_method,_RC) + rh_trans_file = "transpose_"//rh_file inquire(file=rh_file,exist=rh_file_exists) else rh_file_exists = .false. diff --git a/base/MaplGrid.F90 b/base/MaplGrid.F90 index d7b126683be3..1da7d6afa0f5 100644 --- a/base/MaplGrid.F90 +++ b/base/MaplGrid.F90 @@ -337,6 +337,12 @@ subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, layou call MAPL_DistGridGet(distgrid, & minIndex=minindex, & maxIndex=maxindex, _RC) + if (associated(ims)) then + nullify(ims) + end if + if (associated(jms)) then + nullify(jms) + end if call MAPL_GetImsJms(Imins=minindex(1,:),Imaxs=maxindex(1,:),& Jmins=minindex(2,:),Jmaxs=maxindex(2,:),Ims=ims,Jms=jms,_RC) From cc4a1f9520873364a9f8def58ef6081e45bbc3a2 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 7 Mar 2024 09:29:07 -0500 Subject: [PATCH 061/141] fix gfortran issue the right way --- base/MaplGrid.F90 | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/base/MaplGrid.F90 b/base/MaplGrid.F90 index 1da7d6afa0f5..fdac6371357e 100644 --- a/base/MaplGrid.F90 +++ b/base/MaplGrid.F90 @@ -337,17 +337,13 @@ subroutine MAPL_GridGet(GRID, globalCellCountPerDim, localCellCountPerDim, layou call MAPL_DistGridGet(distgrid, & minIndex=minindex, & maxIndex=maxindex, _RC) - if (associated(ims)) then - nullify(ims) - end if - if (associated(jms)) then - nullify(jms) - end if + nullify(ims,jms) call MAPL_GetImsJms(Imins=minindex(1,:),Imaxs=maxindex(1,:),& Jmins=minindex(2,:),Jmaxs=maxindex(2,:),Ims=ims,Jms=jms,_RC) layout(1) = size(ims) layout(2) = size(jms) + deallocate(ims,jms) end if _RETURN(ESMF_SUCCESS) From ecc26ea60c5f1802e5956cbbdd1ca05f0abf2bc9 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 7 Mar 2024 12:10:41 -0500 Subject: [PATCH 062/141] Avoid collective call in grid_is_ok --- CHANGELOG.md | 2 ++ base/Base/Base_Base_implementation.F90 | 13 +++++++------ 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b360d8985b80..d0dd1bc682de 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added + +- Change grd_is_ok function to avoid collective call - Added procedures to remove an attribute from a FileMetadata object and from a Variable object in PFIO - Add per-collection timer output for History - Add python utilities to split and recombine restarts diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 2aef8eb3ecc8..082b300dc26d 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2881,7 +2881,7 @@ function grid_is_ok(grid) result(OK) type(ESMF_Grid), intent(inout) :: grid logical :: OK integer :: I1, I2, J1, J2, j - real(ESMF_KIND_R8), allocatable :: corner_lons(:,:), corner_lats(:,:) + real(ESMF_KIND_R8), pointer :: corner_lons(:,:), corner_lats(:,:) real(ESMF_KIND_R8) :: accurate_lat, accurate_lon real :: tolerance @@ -2889,9 +2889,11 @@ function grid_is_ok(grid) result(OK) call MAPL_GridGetInterior(grid,I1,I2,J1,J2) OK = .true. ! check the edge of face 1 along longitude - allocate(corner_lons(I2-I1+2, J2-J1+2)) - allocate(corner_lats(I2-I1+2, J2-J1+2)) - call MAPL_GridGetCorners(Grid,corner_lons,corner_lats) + call ESMF_GridGetCoord(grid,localDE=0,coordDim=1,staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=corner_lons, rc=status) + call ESMF_GridGetCoord(grid,localDE=0,coordDim=2,staggerloc=ESMF_STAGGERLOC_CORNER, & + farrayPtr=corner_lats, rc=status) + if ( I1 ==1 .and. J2<=IM_WORLD ) then if (J1 == 1) then accurate_lon = 1.750d0*MAPL_PI_R8 - shift @@ -2904,7 +2906,7 @@ function grid_is_ok(grid) result(OK) endif endif - do j = J1, J2+1 + do j = J1+1, J2 accurate_lat = -alpha + (j-1)*dalpha if ( abs(accurate_lat - corner_lats(1,j-J1+1)) > 5.0*tolerance) then print*, "accurate_lat: ", accurate_lat @@ -2919,7 +2921,6 @@ function grid_is_ok(grid) result(OK) enddo endif end function - end subroutine MAPL_GetGlobalHorzIJIndex module subroutine MAPL_GenGridName(im, jm, lon, lat, xyoffset, gridname, geos_style) From 1ce78685c05db0f3df09800b5559f96f66b968ca Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 7 Mar 2024 11:03:55 -0700 Subject: [PATCH 063/141] Error: MAPL_EpochSwathMod.F90, line 877: Undefined pointer XPTR3D used as argument to intrinsic function ASSOCIATED --- .../History/Sampler/MAPL_EpochSwathMod.F90 | 133 +++++++++----- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 168 ++++++++++++++++++ 2 files changed, 258 insertions(+), 43 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index a0b306826fc4..58bb689a17de 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -103,7 +103,7 @@ module MAPL_EpochSwathMod procedure :: check_chunking procedure :: alphabatize_variables procedure :: addVariable_to_acc_bundle - procedure :: addVariable_to_output_bundle +!! procedure :: addVariable_to_output_bundle procedure :: interp_accumulate_fields end type sampler @@ -456,23 +456,22 @@ subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) if (this%vdata%regrid_type == VERTICAL_METHOD_ETA2LEV) call this%vdata%get_interpolating_variable(this%input_bundle,rc=status) _VERIFY(status) + ! __ add field to output_bundle + ! iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call this%CreateVariable(item%xname,rc=status) - _VERIFY(status) + call this%CreateVariable(item%xname,_RC) else if (item%itemType == ItemTypeVector) then - call this%CreateVariable(item%xname,rc=status) - _VERIFY(status) - call this%CreateVariable(item%yname,rc=status) - _VERIFY(status) + call this%CreateVariable(item%xname,_RC) + call this%CreateVariable(item%yname,_RC) end if call iter%next() enddo - ! __ add acc_bundle and output_bundle + ! __ add field to acc_bundle ! this%acc_bundle = ESMF_FieldBundleCreate(_RC) call ESMF_FieldBundleSet(this%acc_bundle,grid=this%output_grid,_RC) @@ -859,10 +858,14 @@ subroutine RegridVector(this,xName,yName,rc) yptr3d => yptr3d_inter end if else - if (associated(xptr3d)) nullify(xptr3d) - if (associated(yptr3d)) nullify(yptr3d) + ! if (associated(xptr3d)) nullify(xptr3d) + ! if (associated(yptr3d)) nullify(yptr3d) + !if (associated(xptr3d)) deallocate(xptr3d) + !if (associated(yptr3d)) deallocate(yptr3d) + nullify(xptr3d, yptr3d) end if +!! _FAIL('nail 1') call ESMF_FieldBundleGet(this%input_bundle,xname,field=xfield,rc=status) _VERIFY(status) call ESMF_FieldBundleGet(this%input_bundle,yname,field=yfield,rc=status) @@ -1018,26 +1021,26 @@ subroutine addVariable_to_acc_bundle(this,itemName,rc) end subroutine addVariable_to_acc_bundle - subroutine addVariable_to_output_bundle(this,itemName,rc) - class (sampler), intent(inout) :: this - character(len=*), intent(in) :: itemName - integer, optional, intent(out) :: rc - - type(ESMF_Field) :: field,newField - integer :: fieldRank - integer :: status - - call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) - call ESMF_FieldGet(field,rank=fieldRank,rc=status) - if (this%doVertRegrid .and. (fieldRank ==3) ) then - newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) - else - newField = MAPL_FieldCreate(field,this%output_grid,_RC) - end if - call MAPL_FieldBundleAdd(this%output_bundle,newField,_RC) - - _RETURN(_SUCCESS) - end subroutine addVariable_to_output_bundle +!! subroutine addVariable_to_output_bundle(this,itemName,rc) +!! class (sampler), intent(inout) :: this +!! character(len=*), intent(in) :: itemName +!! integer, optional, intent(out) :: rc +!! +!! type(ESMF_Field) :: field,newField +!! integer :: fieldRank +!! integer :: status +!! +!! call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) +!! call ESMF_FieldGet(field,rank=fieldRank,rc=status) +!! if (this%doVertRegrid .and. (fieldRank ==3) ) then +!! newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) +!! else +!! newField = MAPL_FieldCreate(field,this%output_grid,_RC) +!! end if +!! call MAPL_FieldBundleAdd(this%output_bundle,newField,_RC) +!! +!! _RETURN(_SUCCESS) +!! end subroutine addVariable_to_output_bundle @@ -1051,7 +1054,7 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) integer, optional, intent(out) :: rc integer :: status - type(ESMF_Field) :: outField + type(ESMF_Field) :: outField, outField2 type(ESMF_Field) :: new_outField type(ESMF_Grid) :: grid @@ -1142,19 +1145,66 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) do while (iter /= this%items%end()) item => iter%get() if (item%itemType == ItemTypeScalar) then - call this%RegridScalar(item%xname,rc=status) - _VERIFY(status) + call this%RegridScalar(item%xname,_RC) call ESMF_FieldBundleGet(this%output_bundle,item%xname,field=outField, _RC) - _VERIFY(status) if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then - call this%vdata%correct_topo(outField,rc=status) - _VERIFY(status) + call this%vdata%correct_topo(outField,_RC) + end if + elseif (item%itemType == ItemTypeVector) then + call this%RegridVector(item%xname,item%yname,_RC) + call ESMF_FieldBundleGet(this%output_bundle,item%xname,field=outField, _RC) + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%correct_topo(outField,_RC) + end if + call ESMF_FieldBundleGet(this%output_bundle,item%yname,field=outField2, _RC) + if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then + call this%vdata%correct_topo(outField2,_RC) end if + end if + + + ! -- mask the time interval + ! store the time interval fields into new bundle + ! xname + call ESMF_FieldGet(outField, Array=array1, _RC) + call ESMF_FieldBundleGet(this%acc_bundle,item%xname,field=new_outField,_RC) + call ESMF_FieldGet(new_outField, Array=array2, _RC) + call ESMF_ArrayGet(array1, rank=rank, _RC) + if (rank==2) then + call ESMF_ArrayGet(array1, farrayptr=pt2d, _RC) + call ESMF_ArrayGet(array2, farrayptr=pt2d_, _RC) + localDe=0 + if (j1(localDe)>0) then + do j= j1(localDe), j2(localDe) + jj= j-jj1+1 ! j_local + !! write(6,*) 'j, jj', j, jj + pt2d_(:,jj) = pt2d(:,jj) + enddo + endif + elseif (rank==3) then + call ESMF_ArrayGet(array1, farrayptr=pt3d, _RC) + call ESMF_ArrayGet(array2, farrayptr=pt3d_, _RC) + do localDe=0, localDEcount-1 + if (j1(localDe)>0) then + do j= j1(localDe), j2(localDe) + jj= j-jj1+1 + pt3d_(:,jj,:) = pt3d(:,jj,:) + enddo + endif + enddo + else + _FAIL('failed interp_accumulate_fields') + endif - ! -- mask the time interval - ! store the time interval fields into new bundle - call ESMF_FieldGet(outField, Array=array1, _RC) - call ESMF_FieldBundleGet(this%acc_bundle,item%xname,field=new_outField,_RC) + ! __ additional step for yname if vector + if (item%itemType == ItemTypeScalar) then + ! already done + elseif (item%itemType == ItemTypeVector) then + ! + ! add yname + ! + call ESMF_FieldGet(outField2, Array=array1, _RC) + call ESMF_FieldBundleGet(this%acc_bundle,item%yname,field=new_outField,_RC) call ESMF_FieldGet(new_outField, Array=array2, _RC) call ESMF_ArrayGet(array1, rank=rank, _RC) if (rank==2) then @@ -1182,9 +1232,6 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) else _FAIL('failed interp_accumulate_fields') endif - - else if (item%itemType == ItemTypeVector) then - _FAIL('ItemTypeVector not implemented') end if call iter%next() enddo diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index c2b213dd664b..b9e1dfba76c4 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -1322,3 +1322,171 @@ end function extract_unquoted_item end submodule HistoryTrajectory_implement + +! subroutine RegridVector(this,xName,yName,rc) +! class (MAPL_GriddedIO), intent(inout) :: this +! character(len=*), intent(in) :: xName +! character(len=*), intent(in) :: yName +! integer, optional, intent(out) :: rc +! +! integer :: status +! +! type(ESMF_Field) :: xfield,xoutField +! type(ESMF_Field) :: yfield,youtField +! integer :: fieldRank +! real, pointer :: xptr3d(:,:,:),xoutptr3d(:,:,:) +! real, pointer :: xptr2d(:,:), xoutptr2d(:,:) +! real, allocatable, target :: xptr3d_inter(:,:,:) +! real, pointer :: yptr3d(:,:,:),youtptr3d(:,:,:) +! real, pointer :: yptr2d(:,:), youtptr2d(:,:) +! real, allocatable, target :: yptr3d_inter(:,:,:) +! type(ESMF_Grid) :: gridIn, gridOut +! logical :: hasDE_in, hasDE_out +! +! call ESMF_FieldBundleGet(this%output_bundle,xName,field=xoutField,rc=status) +! _VERIFY(status) +! call ESMF_FieldBundleGet(this%output_bundle,yName,field=youtField,rc=status) +! _VERIFY(status) +! call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) +! _VERIFY(status) +! call ESMF_FieldBundleGet(this%output_bundle,grid=gridOut,rc=status) +! _VERIFY(status) +! hasDE_in = MAPL_GridHasDE(gridIn,rc=status) +! _VERIFY(status) +! hasDE_out = MAPL_GridHasDE(gridOut,rc=status) +! _VERIFY(status) +! +! if (this%doVertRegrid) then +! call ESMF_FieldBundleGet(this%input_bundle,xName,field=xfield,rc=status) +! _VERIFY(status) +! call ESMF_FieldGet(xField,rank=fieldRank,rc=status) +! _VERIFY(status) +! if (fieldRank==3) then +! if (hasDE_in) then +! call ESMF_FieldGet(xfield,farrayPtr=xptr3d,rc=status) +! _VERIFY(status) +! else +! allocate(xptr3d(0,0,0)) +! end if +! allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),stat=status) +! _VERIFY(status) +! if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then +! call this%vdata%regrid_select_level(xptr3d,xptr3d_inter,rc=status) +! _VERIFY(status) +! else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then +! call this%vdata%regrid_eta_to_pressure(xptr3d,xptr3d_inter,rc=status) +! _VERIFY(status) +! else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then +! call this%vdata%flip_levels(xptr3d,xptr3d_inter,rc=status) +! _VERIFY(status) +! end if +! xptr3d => xptr3d_inter +! end if +! call ESMF_FieldBundleGet(this%input_bundle,yName,field=yfield,rc=status) +! _VERIFY(status) +! call ESMF_FieldGet(yField,rank=fieldRank,rc=status) +! _VERIFY(status) +! if (fieldRank==3) then +! if (hasDE_in) then +! call ESMF_FieldGet(yfield,farrayPtr=yptr3d,rc=status) +! _VERIFY(status) +! else +! allocate(yptr3d(0,0,0)) +! end if +! allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),stat=status) +! _VERIFY(status) +! if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then +! call this%vdata%regrid_select_level(yptr3d,yptr3d_inter,rc=status) +! _VERIFY(status) +! else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then +! call this%vdata%regrid_eta_to_pressure(yptr3d,yptr3d_inter,rc=status) +! _VERIFY(status) +! else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then +! call this%vdata%flip_levels(yptr3d,yptr3d_inter,rc=status) +! _VERIFY(status) +! end if +! yptr3d => yptr3d_inter +! end if +! else +! nullify(xptr3d) +! nullify(yptr3d) +! end if +! +! call ESMF_FieldBundleGet(this%input_bundle,xname,field=xfield,rc=status) +! _VERIFY(status) +! call ESMF_FieldBundleGet(this%input_bundle,yname,field=yfield,rc=status) +! _VERIFY(status) +! call ESMF_FieldGet(xfield,rank=fieldRank,rc=status) +! _VERIFY(status) +! if (fieldRank==2) then +! if (hasDE_in) then +! call MAPL_FieldGetPointer(xfield,xptr2d,rc=status) +! _VERIFY(status) +! call MAPL_FieldGetPointer(yfield,yptr2d,rc=status) +! _VERIFY(status) +! else +! allocate(xptr2d(0,0)) +! allocate(yptr2d(0,0)) +! end if +! +! if (hasDE_in) then +! call MAPL_FieldGetPointer(xOutField,xoutptr2d,rc=status) +! _VERIFY(status) +! call MAPL_FieldGetPointer(yOutField,youtptr2d,rc=status) +! _VERIFY(status) +! else +! allocate(xoutptr2d(0,0)) +! allocate(youtptr2d(0,0)) +! end if +! +! +! if (gridIn==gridOut) then +! xoutPtr2d=xptr2d +! youtPtr2d=yptr2d +! else +! call this%regrid_handle%regrid(xptr2d,yptr2d,xoutPtr2d,youtPtr2d,rc=status) +! _VERIFY(status) +! end if +! else if (fieldRank==3) then +! if (.not.associated(xptr3d)) then +! if (hasDE_in) then +! call MAPL_FieldGetPointer(xfield,xptr3d,rc=status) +! _VERIFY(status) +! else +! allocate(xptr3d(0,0,0)) +! end if +! end if +! if (.not.associated(yptr3d)) then +! if (hasDE_in) then +! call MAPL_FieldGetPointer(yfield,yptr3d,rc=status) +! _VERIFY(status) +! else +! allocate(yptr3d(0,0,0)) +! end if +! end if +! +! if (hasDE_out) then +! call MAPL_FieldGetPointer(xOutField,xoutptr3d,rc=status) +! _VERIFY(status) +! call MAPL_FieldGetPointer(yOutField,youtptr3d,rc=status) +! _VERIFY(status) +! else +! allocate(xoutptr3d(0,0,0)) +! allocate(youtptr3d(0,0,0)) +! end if +! +! if (gridIn==gridOut) then +! xoutPtr3d=xptr3d +! youtPtr3d=yptr3d +! else +! call this%regrid_handle%regrid(xptr3d,yptr3d,xoutPtr3d,youtPtr3d,rc=status) +! _VERIFY(status) +! end if +! end if +! +! if (allocated(xptr3d_inter)) deallocate(xptr3d_inter) +! if (allocated(yptr3d_inter)) deallocate(yptr3d_inter) +! _RETURN(_SUCCESS) +! +! end subroutine RegridVector +! From 426fffd6840fd56da96e368c8c725bc078accf13 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Thu, 7 Mar 2024 13:22:54 -0500 Subject: [PATCH 064/141] just restoring a line that should not have been commented out in last PR --- base/MAPL_EsmfRegridder.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index 6ba2810d3ab2..b20887e8661f 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -250,7 +250,7 @@ subroutine transpose_regrid_scalar_2d_real32(this, q_in, q_out, rc) p_dst = MAPL_UNDEF end if - !call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) + call this%do_regrid(src_field, dst_field, doTranspose=.true., rc=status) _VERIFY(status) if (hasDE) q_out = p_dst From 8e8a0ec87adfebcb0e530ca41e9be3c597d56466 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 7 Mar 2024 14:03:02 -0500 Subject: [PATCH 065/141] replace local horzIJindex search with globalIJIndex search --- CHANGELOG.md | 1 + base/Base/Base_Base_implementation.F90 | 54 +++++++++++--------------- 2 files changed, 23 insertions(+), 32 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 61b83223a490..9d5e9ca557ac 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Replace local HorzIJIndex sear with the GlobalHorzIJindex search - Change grd_is_ok function to avoid collective call - Add option to MAPL regridding layer to write and retrieve ESMF weights. - Add options to History and ExtData to turn on the ability to write and read route handle weights diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 082b300dc26d..6724cd0fdb5b 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2592,14 +2592,17 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) real(ESMF_KIND_R8), pointer :: lats(:,:) real(ESMF_KIND_R8), allocatable :: elons(:) real(ESMF_KIND_R8), allocatable :: elats(:) - integer :: i,iiloc,jjloc + integer :: i,iiloc,jjloc, i1, i2, j1, j2 real(ESMF_KIND_R4) :: lonloc,latloc logical :: localSearch real(ESMF_KIND_R8), allocatable :: target_lons(:),target_lats(:) - real(ESMF_KIND_R8), allocatable :: corner_lons(:,:),corner_lats(:,:),center_lats(:,:),center_lons(:,:) type(ESMF_CoordSys_Flag) :: coordSys character(len=ESMF_MAXSTR) :: grid_type + if (npts == 0 ) then + _RETURN(_SUCCESS) + endif + ! if the grid is present then we can just get the prestored edges and the dimensions of the grid ! this also means we are running on a distributed grid ! if grid not present then the we just be running outside of ESMF and the user must @@ -2615,6 +2618,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) else localSearch = .false. end if + allocate(target_lons(npts),target_lats(npts)) if (present(lon) .and. present(lat)) then target_lons = lon @@ -2624,43 +2628,28 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) target_lats = latR8 end if - _ASSERT(localSearch,"Global Search for IJ not implemented") - !AOO change tusing GridType atribute if (im_world*6==jm_world) then call ESMF_AttributeGet(grid, name='GridType', value=grid_type, _RC) if(trim(grid_type) == "Cubed-Sphere") then - call ESMF_GridGetCoord(grid,coordDim=1, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lons, _RC) - call ESMF_GridGetCoord(grid,coordDim=2, localDe=0, & - staggerloc=ESMF_STAGGERLOC_CENTER, fArrayPtr = lats, _RC) - call ESMF_GridGet(grid,coordSys=coordSys,_RC) - allocate(corner_lons(im+1,jm+1)) - allocate(corner_lats(im+1,jm+1)) - allocate(center_lons(im,jm),center_lats(im,jm)) - if (coordSys==ESMF_COORDSYS_SPH_DEG) then - center_lons=lons*MAPL_DEGREES_TO_RADIANS_R8 - center_lats=lats*MAPL_DEGREES_TO_RADIANS_R8 - else if (coordSys==ESMF_COORDSYS_SPH_RAD) then - center_lons=lons - center_lats=lats - else if (coordSys==ESMF_COORDSYS_CART) then - _FAIL('Unsupported coordinate system: ESMF_COORDSYS_CART') - end if - call MAPL_GridGetCorners(Grid,corner_lons,corner_lats,_RC) - ii=-1 - jj=-1 - call get_points_in_spherical_domain(center_lons,center_lats,corner_lons,corner_lats,target_lons,target_lats,ii,jj,_RC) - deallocate(corner_lons,corner_lats, center_lons,center_lats) + call MAPL_GetGlobalHorzIJIndex(npts, II, JJ, lon=lon, lat=lat, lonR8=lonR8, latR8=latR8, Grid=Grid, rc=rc) + + call MAPL_Grid_Interior(Grid,i1,i2,j1,j2) + ! convert index to local, if it is not in domain, set it to -1 just as the legacy code + where ( i1 <= II .and. II <=i2 .and. j1<=JJ .and. JJ<=j2) + II = II - i1 + 1 + JJ = JJ - j1 + 1 + elsewhere + II = -1 + JJ = -1 + end where + else - if (localSearch) then - call ESMF_GridGetCoord(grid,coordDim=1, localDe=0, & + _ASSERT(localSearch,"Global Search for IJ for latlon not implemented") + call ESMF_GridGetCoord(grid,coordDim=1, localDe=0, & staggerloc=ESMF_STAGGERLOC_CORNER, fArrayPtr = lons, _RC) - call ESMF_GridGetCoord(grid,coordDim=2, localDe=0, & + call ESMF_GridGetCoord(grid,coordDim=2, localDe=0, & staggerloc=ESMF_STAGGERLOC_CORNER, fArrayPtr = lats, _RC) - else - _FAIL('if not isCubed, localSearch must be .true.') - end if allocate(elons(im+1),_STAT) allocate(elats(jm+1),_STAT) call ESMF_GridGet(grid,coordSys=coordSys,_RC) @@ -2686,6 +2675,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) deallocate(elons,elats) end if + deallocate(target_lons, target_lats) _RETURN(ESMF_SUCCESS) contains From 43ea7ba1102f39f2c0a9df36e944678591823942 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 7 Mar 2024 14:32:42 -0700 Subject: [PATCH 066/141] Fixes the error when calling 'regrid_handle%destroy(_RC)' for swath grid in sub. destroy_rh_regen_ogrid 01687 MAPL_EsmfRegridder.F90 --- base/MAPL_EsmfRegridder.F90 | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/base/MAPL_EsmfRegridder.F90 b/base/MAPL_EsmfRegridder.F90 index b20887e8661f..91df059e6623 100644 --- a/base/MAPL_EsmfRegridder.F90 +++ b/base/MAPL_EsmfRegridder.F90 @@ -1665,6 +1665,7 @@ subroutine destroy_route_handle(this, kind, rc) type(ESMF_RouteHandle) :: route_handle type(RegridderSpecRouteHandleMapIterator) :: iter integer :: status + logical :: compute_transpose if (kind == ESMF_TYPEKIND_R4) then route_handles => route_handles_r4 @@ -1684,11 +1685,14 @@ subroutine destroy_route_handle(this, kind, rc) iter = route_handles%find(spec) call route_handles%erase(iter) - _ASSERT(transpose_route_handles%count(spec) == 1, 'Did not find this spec in route handle table.') - route_handle = transpose_route_handles%at(spec) - call ESMF_RouteHandleDestroy(route_handle, noGarbage=.true., _RC) - iter = transpose_route_handles%find(spec) - call transpose_route_handles%erase(iter) + compute_transpose = IAND(spec%hints,REGRID_HINT_COMPUTE_TRANSPOSE) /= 0 + if (compute_transpose) then + _ASSERT(transpose_route_handles%count(spec) == 1, 'Did not find this spec in route handle table.') + route_handle = transpose_route_handles%at(spec) + call ESMF_RouteHandleDestroy(route_handle, noGarbage=.true., _RC) + iter = transpose_route_handles%find(spec) + call transpose_route_handles%erase(iter) + end if _RETURN(_SUCCESS) end subroutine destroy_route_handle From e4d992507c55645f452c60d2056bfaa770a26d4d Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 7 Mar 2024 14:46:43 -0700 Subject: [PATCH 067/141] add CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 882c8bb896ab..720e742c2190 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,6 +8,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added +- Add `if (compute_transpose)` to sub. destroy_route_handle to avoid destroying a nonexisting route handle - Add option to MAPL regridding layer to write and retrieve ESMF weights. - Add options to History and ExtData to turn on the ability to write and read route handle weights - Add option to renable the transpose computation when calling make\_regridder From 187ae9e3fc8e656cd5e071ae5a87b1f54471fe02 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 8 Mar 2024 10:18:40 -0500 Subject: [PATCH 068/141] Fix bug with GriddedIO and Extdata1G --- griddedio/GriddedIO.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index df2f3831aeb4..c8c9f51a10ac 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -56,7 +56,7 @@ module MAPL_GriddedIOMod integer, allocatable :: chunking(:) logical :: itemOrderAlphabetical = .true. integer :: fraction - integer :: regrid_hints + integer :: regrid_hints = 0 contains procedure :: CreateFileMetaData procedure :: CreateVariable From 103c03d27f11ea907e32f1c8bdfb6b9678fd7095 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 8 Mar 2024 15:11:45 -0500 Subject: [PATCH 069/141] Update to ESMA_cmake v3.42.0 --- CHANGELOG.md | 3 ++- components.yaml | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 45199f774b69..846f4465e2dc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,8 +26,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Update `components.yaml` - ESMA_env v4.27.0 (Baselibs 7.18.1) - Moves to HDF5 1.14.3 - - ESMA_cmake v3.41.0 + - ESMA_cmake v3.42.0 - Updates to MPI detection + - Enable `-quiet` flag for NAG ### Fixed diff --git a/components.yaml b/components.yaml index 67c03eaaab00..ab85006d6924 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.41.0 + tag: v3.42.0 develop: develop ecbuild: From d54e9b4415fd455340c31b16f299513aff357ac0 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Mon, 11 Mar 2024 15:47:35 -0400 Subject: [PATCH 070/141] Update base/Base/Base_Base_implementation.F90 --- base/Base/Base_Base_implementation.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 6724cd0fdb5b..46d7a0f1bd15 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2599,10 +2599,7 @@ module subroutine MAPL_GetHorzIJIndex(npts,II,JJ,lon,lat,lonR8,latR8,Grid, rc) type(ESMF_CoordSys_Flag) :: coordSys character(len=ESMF_MAXSTR) :: grid_type - if (npts == 0 ) then - _RETURN(_SUCCESS) - endif - + _RETURN_IF(npts == 0 ) ! if the grid is present then we can just get the prestored edges and the dimensions of the grid ! this also means we are running on a distributed grid ! if grid not present then the we just be running outside of ESMF and the user must From 155fd5d5450b305094413f9dc44cb2ea16d862f3 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 11 Mar 2024 22:50:06 -0400 Subject: [PATCH 071/141] minor improvement to give informative error message when swath grid Epoch does not equal swath sampler frequency --- CHANGELOG.md | 2 ++ .../History/Sampler/MAPL_EpochSwathMod.F90 | 21 +++++++------------ 2 files changed, 10 insertions(+), 13 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d978abadb963..4aa79f452d04 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Add interface to regrid vector for swath sampler +- Give informative error message when swath grid Epoch does not equal swath sampler frequency - Add mask sampler for geostationary satellite (GEOS-R series) - Add geostation name into NC for station sampler - Add mapping between the IODA loc_index and trajectory NC output loc_index diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index 1a7a27cdea38..2cd9a8a961f8 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -203,7 +203,7 @@ subroutine verify_epoch_equals_freq (this, frequency_from_list, swath_grid_label type(ESMF_Config) :: config_grid integer :: hq_epoch_sec integer :: freq_sec - integer :: local_swath_epoch_sec + integer :: local_swath_epoch_sec integer :: time_integer logical :: con integer :: status @@ -226,9 +226,9 @@ subroutine verify_epoch_equals_freq (this, frequency_from_list, swath_grid_label _ASSERT(con, 'Error in '//trim(swath_grid_label)//' related swath and list in History.rc: Epoch in all swath grids must be equal, and equal to list%freq') _RETURN(_SUCCESS) end subroutine verify_epoch_equals_freq - - + + !--------------------------------------------------! ! __ set ! - ogrid via grid_manager%make_grid @@ -356,7 +356,7 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) enddo call ESMF_FieldBundleDestroy(sp%acc_bundle,noGarbage=.true.,_RC) deallocate(names,_STAT) - + call ESMF_FieldBundleGet(sp%output_bundle,fieldCount=numVars,_RC) allocate(names(numVars),_STAT) call ESMF_FieldBundleGet(sp%output_bundle,fieldNameList=names,_RC) @@ -366,7 +366,7 @@ subroutine destroy_rh_regen_ogrid (this, key_grid_label, output_grids, sp, rc) enddo call ESMF_FieldBundleDestroy(sp%output_bundle,noGarbage=.true.,_RC) deallocate(names,_STAT) - + _RETURN(ESMF_SUCCESS) end subroutine destroy_rh_regen_ogrid @@ -507,7 +507,7 @@ subroutine Create_bundle_RH(this,items,bundle,tunit,timeInfo,vdata,ogrid,rc) enddo - ! __ add field to acc_bundle + ! __ add field to acc_bundle ! this%acc_bundle = ESMF_FieldBundleCreate(_RC) call ESMF_FieldBundleSet(this%acc_bundle,grid=this%output_grid,_RC) @@ -894,14 +894,9 @@ subroutine RegridVector(this,xName,yName,rc) yptr3d => yptr3d_inter end if else - ! if (associated(xptr3d)) nullify(xptr3d) - ! if (associated(yptr3d)) nullify(yptr3d) - !if (associated(xptr3d)) deallocate(xptr3d) - !if (associated(yptr3d)) deallocate(yptr3d) nullify(xptr3d, yptr3d) end if -!! _FAIL('nail 1') call ESMF_FieldBundleGet(this%input_bundle,xname,field=xfield,rc=status) _VERIFY(status) call ESMF_FieldBundleGet(this%input_bundle,yname,field=yfield,rc=status) @@ -1197,8 +1192,8 @@ subroutine interp_accumulate_fields (this,xy_subset,rc) call this%vdata%correct_topo(outField2,_RC) end if end if - - + + ! -- mask the time interval ! store the time interval fields into new bundle ! xname From 187897da779db2a5ec2eefe95ec97fbaddccc4ad Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 11 Mar 2024 23:06:52 -0400 Subject: [PATCH 072/141] . --- .../History/Sampler/MAPL_EpochSwathMod.F90 | 25 --- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 170 ------------------ 2 files changed, 195 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index 2cd9a8a961f8..daa47ef388bd 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -95,7 +95,6 @@ module MAPL_EpochSwathMod logical :: have_initalized integer :: epoch_sec contains -!! procedure :: CreateFileMetaData procedure :: Create_bundle_RH procedure :: CreateVariable procedure :: regridScalar @@ -105,7 +104,6 @@ module MAPL_EpochSwathMod procedure :: check_chunking procedure :: alphabatize_variables procedure :: addVariable_to_acc_bundle -!! procedure :: addVariable_to_output_bundle procedure :: interp_accumulate_fields end type sampler @@ -228,7 +226,6 @@ subroutine verify_epoch_equals_freq (this, frequency_from_list, swath_grid_label end subroutine verify_epoch_equals_freq - !--------------------------------------------------! ! __ set ! - ogrid via grid_manager%make_grid @@ -1052,28 +1049,6 @@ subroutine addVariable_to_acc_bundle(this,itemName,rc) end subroutine addVariable_to_acc_bundle -!! subroutine addVariable_to_output_bundle(this,itemName,rc) -!! class (sampler), intent(inout) :: this -!! character(len=*), intent(in) :: itemName -!! integer, optional, intent(out) :: rc -!! -!! type(ESMF_Field) :: field,newField -!! integer :: fieldRank -!! integer :: status -!! -!! call ESMF_FieldBundleGet(this%input_bundle,itemName,field=field,_RC) -!! call ESMF_FieldGet(field,rank=fieldRank,rc=status) -!! if (this%doVertRegrid .and. (fieldRank ==3) ) then -!! newField = MAPL_FieldCreate(field,this%output_grid,lm=this%vData%lm,_RC) -!! else -!! newField = MAPL_FieldCreate(field,this%output_grid,_RC) -!! end if -!! call MAPL_FieldBundleAdd(this%output_bundle,newField,_RC) -!! -!! _RETURN(_SUCCESS) -!! end subroutine addVariable_to_output_bundle - - !! -- based on subroutine bundlepost(this,filename,oClients,rc) !! diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index b9e1dfba76c4..dd0194991622 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -1319,174 +1319,4 @@ function extract_unquoted_item(string_list) result(item) endif end function extract_unquoted_item - - end submodule HistoryTrajectory_implement - -! subroutine RegridVector(this,xName,yName,rc) -! class (MAPL_GriddedIO), intent(inout) :: this -! character(len=*), intent(in) :: xName -! character(len=*), intent(in) :: yName -! integer, optional, intent(out) :: rc -! -! integer :: status -! -! type(ESMF_Field) :: xfield,xoutField -! type(ESMF_Field) :: yfield,youtField -! integer :: fieldRank -! real, pointer :: xptr3d(:,:,:),xoutptr3d(:,:,:) -! real, pointer :: xptr2d(:,:), xoutptr2d(:,:) -! real, allocatable, target :: xptr3d_inter(:,:,:) -! real, pointer :: yptr3d(:,:,:),youtptr3d(:,:,:) -! real, pointer :: yptr2d(:,:), youtptr2d(:,:) -! real, allocatable, target :: yptr3d_inter(:,:,:) -! type(ESMF_Grid) :: gridIn, gridOut -! logical :: hasDE_in, hasDE_out -! -! call ESMF_FieldBundleGet(this%output_bundle,xName,field=xoutField,rc=status) -! _VERIFY(status) -! call ESMF_FieldBundleGet(this%output_bundle,yName,field=youtField,rc=status) -! _VERIFY(status) -! call ESMF_FieldBundleGet(this%input_bundle,grid=gridIn,rc=status) -! _VERIFY(status) -! call ESMF_FieldBundleGet(this%output_bundle,grid=gridOut,rc=status) -! _VERIFY(status) -! hasDE_in = MAPL_GridHasDE(gridIn,rc=status) -! _VERIFY(status) -! hasDE_out = MAPL_GridHasDE(gridOut,rc=status) -! _VERIFY(status) -! -! if (this%doVertRegrid) then -! call ESMF_FieldBundleGet(this%input_bundle,xName,field=xfield,rc=status) -! _VERIFY(status) -! call ESMF_FieldGet(xField,rank=fieldRank,rc=status) -! _VERIFY(status) -! if (fieldRank==3) then -! if (hasDE_in) then -! call ESMF_FieldGet(xfield,farrayPtr=xptr3d,rc=status) -! _VERIFY(status) -! else -! allocate(xptr3d(0,0,0)) -! end if -! allocate(xptr3d_inter(size(xptr3d,1),size(xptr3d,2),this%vdata%lm),stat=status) -! _VERIFY(status) -! if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then -! call this%vdata%regrid_select_level(xptr3d,xptr3d_inter,rc=status) -! _VERIFY(status) -! else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then -! call this%vdata%regrid_eta_to_pressure(xptr3d,xptr3d_inter,rc=status) -! _VERIFY(status) -! else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then -! call this%vdata%flip_levels(xptr3d,xptr3d_inter,rc=status) -! _VERIFY(status) -! end if -! xptr3d => xptr3d_inter -! end if -! call ESMF_FieldBundleGet(this%input_bundle,yName,field=yfield,rc=status) -! _VERIFY(status) -! call ESMF_FieldGet(yField,rank=fieldRank,rc=status) -! _VERIFY(status) -! if (fieldRank==3) then -! if (hasDE_in) then -! call ESMF_FieldGet(yfield,farrayPtr=yptr3d,rc=status) -! _VERIFY(status) -! else -! allocate(yptr3d(0,0,0)) -! end if -! allocate(yptr3d_inter(size(yptr3d,1),size(yptr3d,2),this%vdata%lm),stat=status) -! _VERIFY(status) -! if (this%vdata%regrid_type==VERTICAL_METHOD_SELECT) then -! call this%vdata%regrid_select_level(yptr3d,yptr3d_inter,rc=status) -! _VERIFY(status) -! else if (this%vdata%regrid_type==VERTICAL_METHOD_ETA2LEV) then -! call this%vdata%regrid_eta_to_pressure(yptr3d,yptr3d_inter,rc=status) -! _VERIFY(status) -! else if (this%vdata%regrid_type==VERTICAL_METHOD_FLIP) then -! call this%vdata%flip_levels(yptr3d,yptr3d_inter,rc=status) -! _VERIFY(status) -! end if -! yptr3d => yptr3d_inter -! end if -! else -! nullify(xptr3d) -! nullify(yptr3d) -! end if -! -! call ESMF_FieldBundleGet(this%input_bundle,xname,field=xfield,rc=status) -! _VERIFY(status) -! call ESMF_FieldBundleGet(this%input_bundle,yname,field=yfield,rc=status) -! _VERIFY(status) -! call ESMF_FieldGet(xfield,rank=fieldRank,rc=status) -! _VERIFY(status) -! if (fieldRank==2) then -! if (hasDE_in) then -! call MAPL_FieldGetPointer(xfield,xptr2d,rc=status) -! _VERIFY(status) -! call MAPL_FieldGetPointer(yfield,yptr2d,rc=status) -! _VERIFY(status) -! else -! allocate(xptr2d(0,0)) -! allocate(yptr2d(0,0)) -! end if -! -! if (hasDE_in) then -! call MAPL_FieldGetPointer(xOutField,xoutptr2d,rc=status) -! _VERIFY(status) -! call MAPL_FieldGetPointer(yOutField,youtptr2d,rc=status) -! _VERIFY(status) -! else -! allocate(xoutptr2d(0,0)) -! allocate(youtptr2d(0,0)) -! end if -! -! -! if (gridIn==gridOut) then -! xoutPtr2d=xptr2d -! youtPtr2d=yptr2d -! else -! call this%regrid_handle%regrid(xptr2d,yptr2d,xoutPtr2d,youtPtr2d,rc=status) -! _VERIFY(status) -! end if -! else if (fieldRank==3) then -! if (.not.associated(xptr3d)) then -! if (hasDE_in) then -! call MAPL_FieldGetPointer(xfield,xptr3d,rc=status) -! _VERIFY(status) -! else -! allocate(xptr3d(0,0,0)) -! end if -! end if -! if (.not.associated(yptr3d)) then -! if (hasDE_in) then -! call MAPL_FieldGetPointer(yfield,yptr3d,rc=status) -! _VERIFY(status) -! else -! allocate(yptr3d(0,0,0)) -! end if -! end if -! -! if (hasDE_out) then -! call MAPL_FieldGetPointer(xOutField,xoutptr3d,rc=status) -! _VERIFY(status) -! call MAPL_FieldGetPointer(yOutField,youtptr3d,rc=status) -! _VERIFY(status) -! else -! allocate(xoutptr3d(0,0,0)) -! allocate(youtptr3d(0,0,0)) -! end if -! -! if (gridIn==gridOut) then -! xoutPtr3d=xptr3d -! youtPtr3d=yptr3d -! else -! call this%regrid_handle%regrid(xptr3d,yptr3d,xoutPtr3d,youtPtr3d,rc=status) -! _VERIFY(status) -! end if -! end if -! -! if (allocated(xptr3d_inter)) deallocate(xptr3d_inter) -! if (allocated(yptr3d_inter)) deallocate(yptr3d_inter) -! _RETURN(_SUCCESS) -! -! end subroutine RegridVector -! From 2e67a65055a9de201a67d604537108fda5d51184 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 11 Mar 2024 23:12:23 -0400 Subject: [PATCH 073/141] removed an extra line of code --- gridcomps/History/MAPL_HistoryGridComp.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index e3d52a3d0650..a19778632ab1 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2398,7 +2398,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call list(n)%xsampler%set_param(nbits_to_keep=list(n)%nbits_to_keep,_RC) call list(n)%xsampler%set_param(regrid_method=list(n)%regrid_method,_RC) call list(n)%xsampler%set_param(itemOrder=intState%fileOrderAlphabetical,_RC) - call ESMF_TimeIntervalGet(Hsampler%Frequency_epoch, s=sec, _RC) call Hsampler%verify_epoch_equals_freq (list(n)%frequency, list(n)%output_grid_label, _RC) endif From a2e15a646f40c27d304ba797c271a87794ac0146 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 12 Mar 2024 11:33:13 -0400 Subject: [PATCH 074/141] make an explicit item in CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4aa79f452d04..d9bcc35bd9a5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Add interface to regrid vector for swath sampler +- Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) - Give informative error message when swath grid Epoch does not equal swath sampler frequency - Add mask sampler for geostationary satellite (GEOS-R series) - Add geostation name into NC for station sampler From 6d4c30a1caec92da2517cc71089099d167a8d728 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 13 Mar 2024 04:39:21 -0400 Subject: [PATCH 075/141] Add LS_chunk (distributed) as intermediate step to LS_ds (with CS background) --- base/MAPL_LocStreamFactoryMod.F90 | 31 +++++++ .../History/Sampler/MAPL_TrajectoryMod.F90 | 4 + .../Sampler/MAPL_TrajectoryMod_smod.F90 | 87 ++++++++++++++++--- 3 files changed, 111 insertions(+), 11 deletions(-) diff --git a/base/MAPL_LocStreamFactoryMod.F90 b/base/MAPL_LocStreamFactoryMod.F90 index 6ffc0acfdb3b..89bc14c42e2c 100644 --- a/base/MAPL_LocStreamFactoryMod.F90 +++ b/base/MAPL_LocStreamFactoryMod.F90 @@ -20,6 +20,7 @@ module LocStreamFactoryMod real(kind=REAL64), allocatable :: lats(:) contains procedure :: create_locstream + procedure :: create_locstream_on_proc procedure :: destroy_locstream end type @@ -95,6 +96,36 @@ function create_locstream(this,unusable,grid,rc) result(locstream) _RETURN(_SUCCESS) end function create_locstream + function create_locstream_on_proc (this,unusable,grid,rc) result(locstream) + type(ESMF_LocStream) :: locstream + class (LocStreamFactory) :: this + class (KeywordEnforcer), optional, intent(in) :: unusable + type(ESMF_Grid), optional :: grid + integer, optional, intent(out) :: rc + + integer :: local_count,status + real(kind=REAL64), allocatable :: tlons(:),tlats(:) + + local_count = size(this%lons) + allocate(tlons(size(this%lons)),source=this%lons,stat=status) + _VERIFY(status) + allocate(tlats(size(this%lats)),source=this%lats,stat=status) + _VERIFY(status) + + tlons=tlons*MAPL_PI_R8/180.0d0 + tlats=tlats*MAPL_PI_R8/180.0d0 + + locstream = ESMF_LocStreamCreate(localCount=local_count,coordSys=ESMF_COORDSYS_SPH_RAD,_RC) + call ESMF_LocStreamAddKey(locstream,keyName="ESMF:Lat",farray=tlats,datacopyflag=ESMF_DATACOPY_VALUE, & + keyUnits="Radians", keyLongName="Latitude",_RC) + call ESMF_LocStreamAddKey(locstream,keyName="ESMF:Lon",farray=tlons,datacopyflag=ESMF_DATACOPY_VALUE, & + keyUnits="Radians", keyLongName="Longitude",_RC) + + if (present(grid)) then + locstream = ESMF_LocStreamCreate(locstream,background=grid,_RC) + end if + _RETURN(_SUCCESS) + end function create_locstream_on_proc subroutine destroy_locstream(this,locstream,rc) class (LocStreamFactory) :: this diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 index 44ae9194aa40..ee410b3fdfe7 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -17,12 +17,16 @@ module HistoryTrajectoryMod private type(ESMF_LocStream) :: LS_rt type(ESMF_LocStream) :: LS_ds + type(ESMF_LocStream) :: LS_chunk type(LocStreamFactory) :: locstream_factory type(obs_unit), allocatable :: obs(:) type(ESMF_Time), allocatable :: times(:) real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: times_R8(:) +! real(kind=REAL64), allocatable :: lons_chunk(:) +! real(kind=REAL64), allocatable :: lats_chunk(:) +! real(kind=REAL64), allocatable :: times_R8_chunk(:) integer, allocatable :: obstype_id(:) integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index dd0194991622..2c28db659a0f 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -20,6 +20,7 @@ use MAPL_StringTemplate use Plain_netCDF_Time use MAPL_ObsUtilMod + use MPI, only : MPI_REAL, MPI_DOUBLE_PRECISION, MPI_INTEGER use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -309,7 +310,6 @@ this%output_bundle = this%create_new_bundle(_RC) this%acc_bundle = this%create_new_bundle(_RC) - do k=1, this%nobs_type call this%obs(k)%metadata%add_dimension(this%index_name_x, this%obs(k)%nobs_epoch) if (this%time_info%integer_time) then @@ -538,7 +538,7 @@ type(ESMF_Grid) :: grid type(ESMF_VM) :: vm - integer :: mypet, petcount + integer :: mypet, petcount, mpic integer :: i, j, k, L, ii, jj integer :: fid_s, fid_e @@ -554,13 +554,20 @@ integer :: nx2 logical :: EX ! file logical :: zero_obs - + integer, allocatable :: sendcount(:), displs(:) + integer :: recvcount + integer :: is, ie, ierr + + real(kind=REAL64), allocatable :: lons_chunk(:) + real(kind=REAL64), allocatable :: lats_chunk(:) + real(kind=REAL64), allocatable :: times_R8_chunk(:) + !! this%datetime_units = "seconds since 1970-01-01 00:00:00" lgr => logging%get_logger('HISTORY.sampler') call ESMF_VMGetGlobal(vm,_RC) - call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) - + call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) + if (this%index_name_x == '') then ! !-- non IODA case / non netCDF @@ -835,20 +842,77 @@ this%nobs_epoch_sum = nx_sum call lgr%debug('%a %i20', 'nobservation points=', nx_sum) + ! + !__ s1. distrubute uniformly the locstream points + !__ s2. create ls on parallel processors + ! + + + ! caution about zero-sized array for MPI + ! + +!! ! mod +!! nx_sum=200 + nx = int ( nx_sum / petCount ) ! each proc + if (mypet == petCount -1) nx = nx_sum - nx * (petCount -1) ! reuse nx + allocate ( sendcount (petCount) ) + allocate ( displs (petCount) ) + recvcount = nx + sendcount ( 1:petCount-1 ) = int ( nx_sum / petCount ) + sendcount ( petcount ) = nx_sum - int ( nx_sum / petCount ) * (petCount-1) + displs(1)=0 + do i = 2, petCount + displs(i) = displs(i-1) + sendcount(i-1) + end do + write(6,'(2x,a,10i8)') 'ck mypet, nx, recvcount', & + mypet, nx, recvcount + write(6,'(2x,a,10i8)') 'sendcount', sendcount + write(6,'(2x,a,10i8)') 'displs', displs + is = nx * mypet + 1 + ie = nx * (mypet + 1) + if (mypet == petCount -1) ie = nx_sum + + + allocate ( lons_chunk (nx) ) + allocate ( lats_chunk (nx) ) + allocate ( times_R8_chunk (nx) ) + + call MPI_Scatterv( this%lons, sendcount, & + displs, MPI_DOUBLE_PRECISION, lons_chunk, & + recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) + + call MPI_Scatterv( this%lats, sendcount, & + displs, MPI_DOUBLE_PRECISION, lats_chunk, & + recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) + + call MPI_Scatterv( this%times_R8, sendcount, & + displs, MPI_DOUBLE_PRECISION, times_R8_chunk, & + recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) + + call MPI_Barrier(mpic, status) +! write(6,'(2x,a,2i8)') 'ck mypet, nx, lons_chunk(1:nx)',& +! mypet, nx +! write(6,'(10f10.2)') lons_chunk(1:nx) +!! _FAIL('nail 1') + + ! -- root this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) this%LS_rt = this%locstream_factory%create_locstream(_RC) + + ! -- proc + this%locstream_factory = LocStreamFactory(lons_chunk,lats_chunk,_RC) + this%LS_chunk = this%locstream_factory%create_locstream_on_proc(_RC) + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) - this%LS_ds = this%locstream_factory%create_locstream(grid=grid,_RC) + this%LS_ds = this%locstream_factory%create_locstream_on_proc(grid=grid,_RC) - this%fieldA = ESMF_FieldCreate (this%LS_rt, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) + this%fieldA = ESMF_FieldCreate (this%LS_chunk, name='A_time', typekind=ESMF_TYPEKIND_R8, _RC) this%fieldB = ESMF_FieldCreate (this%LS_ds, name='B_time', typekind=ESMF_TYPEKIND_R8, _RC) call ESMF_FieldGet( this%fieldA, localDE=0, farrayPtr=ptAT) call ESMF_FieldGet( this%fieldB, localDE=0, farrayPtr=this%obsTime) - if (mypet == 0) then - ptAT(:) = this%times_R8(:) - end if + ptAT(:) = times_R8_chunk(:) this%obsTime= -1.d0 call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) @@ -860,7 +924,8 @@ call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) ! defer destroy fieldB at regen_grid step ! - + + !!_FAIL('nail 1') _RETURN(_SUCCESS) end procedure create_grid From 08cc6f746b03a7cd6a4599297edfba257c4003a4 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 13 Mar 2024 08:12:49 -0400 Subject: [PATCH 076/141] clean up --- .../History/Sampler/MAPL_TrajectoryMod.F90 | 3 --- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 24 +++++++------------ 2 files changed, 8 insertions(+), 19 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 index ee410b3fdfe7..2f51ceb4c8db 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -24,9 +24,6 @@ module HistoryTrajectoryMod real(kind=REAL64), allocatable :: lons(:) real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: times_R8(:) -! real(kind=REAL64), allocatable :: lons_chunk(:) -! real(kind=REAL64), allocatable :: lats_chunk(:) -! real(kind=REAL64), allocatable :: times_R8_chunk(:) integer, allocatable :: obstype_id(:) integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 2c28db659a0f..eb1c4571e5f0 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -567,7 +567,7 @@ call ESMF_VMGetGlobal(vm,_RC) call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) - + if (this%index_name_x == '') then ! !-- non IODA case / non netCDF @@ -846,13 +846,8 @@ !__ s1. distrubute uniformly the locstream points !__ s2. create ls on parallel processors ! - - ! caution about zero-sized array for MPI ! - -!! ! mod -!! nx_sum=200 nx = int ( nx_sum / petCount ) ! each proc if (mypet == petCount -1) nx = nx_sum - nx * (petCount -1) ! reuse nx allocate ( sendcount (petCount) ) @@ -864,15 +859,6 @@ do i = 2, petCount displs(i) = displs(i-1) + sendcount(i-1) end do - - write(6,'(2x,a,10i8)') 'ck mypet, nx, recvcount', & - mypet, nx, recvcount - write(6,'(2x,a,10i8)') 'sendcount', sendcount - write(6,'(2x,a,10i8)') 'displs', displs - is = nx * mypet + 1 - ie = nx * (mypet + 1) - if (mypet == petCount -1) ie = nx_sum - allocate ( lons_chunk (nx) ) allocate ( lats_chunk (nx) ) @@ -891,10 +877,16 @@ recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) call MPI_Barrier(mpic, status) + +!- test print out +! write(6,'(2x,a,10i8)') 'ck mypet, nx, recvcount', & +! mypet, nx, recvcount +! write(6,'(2x,a,10i8)') 'sendcount', sendcount +! write(6,'(2x,a,10i8)') 'displs', displs ! write(6,'(2x,a,2i8)') 'ck mypet, nx, lons_chunk(1:nx)',& ! mypet, nx ! write(6,'(10f10.2)') lons_chunk(1:nx) -!! _FAIL('nail 1') + ! -- root this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) From e36b3e41ada59be7925425d368901a337708469f Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 13 Mar 2024 11:12:08 -0400 Subject: [PATCH 077/141] . --- gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index eb1c4571e5f0..c10290c373a1 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -562,7 +562,6 @@ real(kind=REAL64), allocatable :: lats_chunk(:) real(kind=REAL64), allocatable :: times_R8_chunk(:) -!! this%datetime_units = "seconds since 1970-01-01 00:00:00" lgr => logging%get_logger('HISTORY.sampler') call ESMF_VMGetGlobal(vm,_RC) @@ -843,8 +842,8 @@ call lgr%debug('%a %i20', 'nobservation points=', nx_sum) ! - !__ s1. distrubute uniformly the locstream points - !__ s2. create ls on parallel processors + !__ s1. distrubute data chunk for the locstream points : mpi_scatterV + !__ s2. create LS on parallel processors ! ! caution about zero-sized array for MPI ! From 605e816183e2a6773fbda237419835ec4c2f861d Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 14 Mar 2024 16:20:35 -0400 Subject: [PATCH 078/141] WIP: towards ls_ds -> ls_chunk -> ls_rt --- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 468 ++++++++++-------- 1 file changed, 264 insertions(+), 204 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index c10290c373a1..5c188e49bd23 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -561,10 +561,11 @@ real(kind=REAL64), allocatable :: lons_chunk(:) real(kind=REAL64), allocatable :: lats_chunk(:) real(kind=REAL64), allocatable :: times_R8_chunk(:) - + + integer :: na, nb lgr => logging%get_logger('HISTORY.sampler') - call ESMF_VMGetGlobal(vm,_RC) + call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) if (this%index_name_x == '') then @@ -844,21 +845,38 @@ ! !__ s1. distrubute data chunk for the locstream points : mpi_scatterV !__ s2. create LS on parallel processors + ! caution about zero-sized array for MPI ! - ! caution about zero-sized array for MPI - ! - nx = int ( nx_sum / petCount ) ! each proc - if (mypet == petCount -1) nx = nx_sum - nx * (petCount -1) ! reuse nx + +! nx = int ( nx_sum / petCount ) ! each proc +! if (mypet == petCount -1) nx = nx_sum - nx * (petCount -1) ! reuse nx +! allocate ( sendcount (petCount) ) +! allocate ( displs (petCount) ) +! recvcount = nx +! sendcount ( 1:petCount-1 ) = int ( nx_sum / petCount ) +! sendcount ( petcount ) = nx_sum - int ( nx_sum / petCount ) * (petCount-1) +! displs(1)=0 +! do i = 2, petCount +! displs(i) = displs(i-1) + sendcount(i-1) +! end do + + na = int ( nx_sum / petCount ) ! base length + nb = nx_sum - na * (petCount -1) ! exception + if (mypet < petCount -1) then + recvcount = na + else + recvcount = nb + end if allocate ( sendcount (petCount) ) allocate ( displs (petCount) ) - recvcount = nx - sendcount ( 1:petCount-1 ) = int ( nx_sum / petCount ) - sendcount ( petcount ) = nx_sum - int ( nx_sum / petCount ) * (petCount-1) + sendcount ( 1:petCount-1 ) = na + sendcount ( petcount ) = nb displs(1)=0 do i = 2, petCount displs(i) = displs(i-1) + sendcount(i-1) - end do - + end do + + allocate ( lons_chunk (nx) ) allocate ( lats_chunk (nx) ) allocate ( times_R8_chunk (nx) ) @@ -922,198 +940,6 @@ end procedure create_grid - - module procedure append_file - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_RouteHandle) :: RH - - type(ESMF_Field) :: src_field, dst_field - type(ESMF_Field) :: acc_field - type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt - real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) - real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) - - integer :: is, ie, nx - integer :: lm - integer :: rank - integer :: status - integer :: j, k, ig - integer, allocatable :: ix(:) - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - rc=0 - return - endif - - is=1 - do k = 1, this%nobs_type - !-- limit nx < 2**32 (integer*4) - nx=this%obs(k)%nobs_epoch - if (nx >0) then - if (mapl_am_i_root()) then - call this%obs(k)%file_handle%put_var(this%var_name_time, real(this%obs(k)%times_R8), & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%var_name_lon, this%obs(k)%lons, & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & - start=[is], count=[nx], _RC) - end if - end if - enddo - - ! get RH from 2d field - src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) - dst_field = ESMF_FieldCreate(this%LS_rt,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) - call ESMF_FieldRedistStore(src_field,dst_field,RH,_RC) - call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) - - ! redist and put_var - lm = this%vdata%lm - acc_field_2d_rt = ESMF_FieldCreate (this%LS_rt, name='field_2d_rt', typekind=ESMF_TYPEKIND_R4, _RC) - acc_field_3d_rt = ESMF_FieldCreate (this%LS_rt, name='field_3d_rt', typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) - call ESMF_FieldGet(acc_field,rank=rank,_RC) - if (rank==1) then -!! if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:2d item%xname', trim(item%xname) - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC) - call ESMF_FieldGet( acc_field_2d_rt, localDE=0, farrayPtr=p_acc_rt_2d, _RC) - call ESMF_FieldRedist( acc_field, acc_field_2d_rt, RH, _RC) - if (mapl_am_i_root()) then - ! - !-- pack fields to obs(k)%p2d and put_var - ! - is=1 - ie=this%epoch_index(2)-this%epoch_index(1)+1 - do k=1, this%nobs_type - nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p2d(nx), _STAT) - enddo - - allocate(ix(this%nobs_type), _STAT) - ix(:)=0 - do j=is, ie - k = this%obstype_id(j) - ix(k) = ix(k) + 1 - this%obs(k)%p2d(ix(k)) = p_acc_rt_2d(j) - enddo - - do k=1, this%nobs_type - if (ix(k) /= this%obs(k)%nobs_epoch) then - print*, 'obs_', k, ' : ix(k) /= this%obs(k)%nobs_epoch' - print*, 'obs_', k, ' : this%obs(k)%nobs_epoch, ix(k) =', this%obs(k)%nobs_epoch, ix(k) - _FAIL('test ix(k) failed') - endif - enddo - deallocate(ix, _STAT) - do k=1, this%nobs_type - is = 1 - nx = this%obs(k)%nobs_epoch - if (nx>0) then - do ig = 1, this%obs(k)%ngeoval - !!write(6,'(2x,a,2x,a)') 't this%obs(k)%geoval_xname(ig)', trim(this%obs(k)%geoval_xname(ig)) - if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - !!write(6, '(2x,a,2x,a)') 'append:2d inner put_var item%xname', trim(item%xname) - call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & - start=[is],count=[nx]) - end if - enddo - endif - enddo - do k=1, this%nobs_type - deallocate (this%obs(k)%p2d, _STAT) - enddo - end if - else if (rank==2) then - !!if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:3d item%xname', trim(item%xname) - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) - call ESMF_FieldGet( acc_field_3d_rt, localDE=0, farrayPtr=p_acc_rt_3d, _RC) - - dst_field=ESMF_FieldCreate(this%LS_rt,typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) - call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) - - p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) - call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) - p_acc_rt_3d=reshape(p_dst, shape(p_acc_rt_3d), order=[2,1]) - - call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) - call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - - if (mapl_am_i_root()) then - ! - !-- pack fields to obs(k)%p3d and put_var - ! - is=1 - ie=this%epoch_index(2)-this%epoch_index(1)+1 - do k=1, this%nobs_type - nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2)), _STAT) - enddo - allocate(ix(this%nobs_type), _STAT) - ix(:)=0 - do j=is, ie - k = this%obstype_id(j) - ix(k) = ix(k) + 1 - this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) - enddo - deallocate(ix, _STAT) - do k=1, this%nobs_type - is = 1 - nx = this%obs(k)%nobs_epoch - if (nx>0) then - do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - !!write(6, '(2x,a,2x,a)') 'append:3d inner put_var item%xname', trim(item%xname) - call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & - start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - end if - end do - endif - enddo - !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) - !!write(6,*) 'here in append_file: put_var 3d' - !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& - !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - !! - do k=1, this%nobs_type - deallocate (this%obs(k)%p3d, _STAT) - enddo - end if - endif - else if (item%itemType == ItemTypeVector) then - _FAIL("ItemTypeVector not yet supported") - end if - call iter%next() - enddo - call ESMF_FieldDestroy(acc_field_2d_rt, noGarbage=.true., _RC) - call ESMF_FieldDestroy(acc_field_3d_rt, noGarbage=.true., _RC) - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - - _RETURN(_SUCCESS) - end procedure append_file - - - - module procedure regrid_accumulate_on_xsubset integer :: x_subset(2) type(ESMF_Time) :: timeset(2) @@ -1163,7 +989,7 @@ ! !!arr(1)=1 !!if (.NOT. (is > 0 .AND. is <= ie )) arr(1)=0 - !!call ESMF_VMGetGlobal(vm,_RC) + !!call ESMF_VMGetCurrent(vm,_RC) !!call ESMF_VMGet(vm, localPet=mypet, petCount=petCount, _RC) !!call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx_sum, & !! count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) @@ -1375,4 +1201,238 @@ function extract_unquoted_item(string_list) result(item) endif end function extract_unquoted_item + + module procedure append_file + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_RouteHandle) :: RH + + type(ESMF_Field) :: src_field, dst_field + type(ESMF_Field) :: acc_field + type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt + real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) + real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) + real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) + + type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field + real(kind=REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) + + integer :: is, ie, nx + integer :: lm + integer :: rank + integer :: status + integer :: j, k, ig + integer, allocatable :: ix(:) + type(ESMF_VM) :: vm + integer :: mypet, petcount, mpic + + integer :: na, nb, nx_sum, nsend + integer, allocatable :: RECVCOUNT(:), displs(:) + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + is=1 + do k = 1, this%nobs_type + !-- limit nx < 2**32 (integer*4) + nx=this%obs(k)%nobs_epoch + if (nx >0) then + if (mapl_am_i_root()) then + call this%obs(k)%file_handle%put_var(this%var_name_time, real(this%obs(k)%times_R8), & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%var_name_lon, this%obs(k)%lons, & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & + start=[is], count=[nx], _RC) + end if + end if + enddo + + ! get RH from 2d field + src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + chunk_field = ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + call ESMF_FieldRedistStore(src_field,chunk_field,RH,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(chunk_field,noGarbage=.true.,_RC) + + ! redist and put_var + lm = this%vdata%lm + acc_field_2d_rt = ESMF_FieldCreate (this%LS_rt, name='field_2d_rt', typekind=ESMF_TYPEKIND_R4, _RC) + acc_field_3d_rt = ESMF_FieldCreate (this%LS_rt, name='field_3d_rt', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + acc_field_2d_chunk = ESMF_FieldCreate (this%LS_chunk, name='field_2d_chunk', typekind=ESMF_TYPEKIND_R4, _RC) + acc_field_3d_chunk = ESMF_FieldCreate (this%LS_chunk, name='field_3d_chunk', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + ! + ! caution about zero-sized array for MPI + ! + nx_sum = this%nobs_epoch_sum + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) + + na = int ( nx_sum / petCount ) ! base length + nb = nx_sum - na * (petCount -1) ! exception + if (mypet /= petCount -1) then + nsend = na + else + nsend = nb + end if + allocate ( recvcount (petCount) ) + allocate ( displs (petCount) ) + recvcount ( 1:petCount-1 ) = na + recvcount ( petcount ) = nb + displs(1)=0 + do i = 2, petCount + displs(i) = displs(i-1) + recvcount(i-1) + end do + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) + call ESMF_FieldGet(acc_field,rank=rank,_RC) + if (rank==1) then +!! if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:2d item%xname', trim(item%xname) + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC) + call ESMF_FieldGet( acc_field_2d_chunk, localDE=0, farrayPtr=p_acc_chunk_2d, _RC) + call ESMF_FieldRedist( acc_field, acc_field_2d_chunk, RH, _RC) + ! + ! call gatherV + + + if (mapl_am_i_root()) then + ! + !-- pack fields to obs(k)%p2d and put_var + ! + is=1 + ie=this%epoch_index(2)-this%epoch_index(1)+1 + do k=1, this%nobs_type + nx = this%obs(k)%nobs_epoch + allocate (this%obs(k)%p2d(nx), _STAT) + enddo + + allocate(ix(this%nobs_type), _STAT) + ix(:)=0 + do j=is, ie + k = this%obstype_id(j) + ix(k) = ix(k) + 1 + this%obs(k)%p2d(ix(k)) = p_acc_rt_2d(j) + enddo + + do k=1, this%nobs_type + if (ix(k) /= this%obs(k)%nobs_epoch) then + print*, 'obs_', k, ' : ix(k) /= this%obs(k)%nobs_epoch' + print*, 'obs_', k, ' : this%obs(k)%nobs_epoch, ix(k) =', this%obs(k)%nobs_epoch, ix(k) + _FAIL('test ix(k) failed') + endif + enddo + deallocate(ix, _STAT) + do k=1, this%nobs_type + is = 1 + nx = this%obs(k)%nobs_epoch + if (nx>0) then + do ig = 1, this%obs(k)%ngeoval + !!write(6,'(2x,a,2x,a)') 't this%obs(k)%geoval_xname(ig)', trim(this%obs(k)%geoval_xname(ig)) + if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then + !!write(6, '(2x,a,2x,a)') 'append:2d inner put_var item%xname', trim(item%xname) + call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & + start=[is],count=[nx]) + end if + enddo + endif + enddo + do k=1, this%nobs_type + deallocate (this%obs(k)%p2d, _STAT) + enddo + end if + + + else if (rank==2) then + !!if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:3d item%xname', trim(item%xname) + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) + call ESMF_FieldGet( acc_field_3d_chunk, localDE=0, farrayPtr=p_acc_chunk_3d, _RC) + + dst_field=ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) + call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) + + p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) + call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) + p_acc_chunk_3d=reshape(p_dst, shape(p_acc_chunk_3d), order=[2,1]) + + call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + + if (mapl_am_i_root()) then + ! + !-- pack fields to obs(k)%p3d and put_var + ! + is=1 + ie=this%epoch_index(2)-this%epoch_index(1)+1 + do k=1, this%nobs_type + nx = this%obs(k)%nobs_epoch + allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2)), _STAT) + enddo + allocate(ix(this%nobs_type), _STAT) + ix(:)=0 + do j=is, ie + k = this%obstype_id(j) + ix(k) = ix(k) + 1 + this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) + enddo + deallocate(ix, _STAT) + do k=1, this%nobs_type + is = 1 + nx = this%obs(k)%nobs_epoch + if (nx>0) then + do ig = 1, this%obs(k)%ngeoval + if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then + !!write(6, '(2x,a,2x,a)') 'append:3d inner put_var item%xname', trim(item%xname) + call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & + start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + end if + end do + endif + enddo + !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) + !!write(6,*) 'here in append_file: put_var 3d' + !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& + !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + !! + do k=1, this%nobs_type + deallocate (this%obs(k)%p3d, _STAT) + enddo + end if + endif + + else if (item%itemType == ItemTypeVector) then + _FAIL("ItemTypeVector not yet supported") + end if + call iter%next() + enddo + call ESMF_FieldDestroy(acc_field_2d_chunk, noGarbage=.true., _RC) + call ESMF_FieldDestroy(acc_field_3d_chunk, noGarbage=.true., _RC) + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + + _RETURN(_SUCCESS) + end procedure append_file + + + + end submodule HistoryTrajectory_implement From bce34fa334195a40b9153bbf65d9221fa458edb4 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 15 Mar 2024 10:06:52 -0400 Subject: [PATCH 079/141] Update to ESMA_cmake v3.42.0 --- CHANGELOG.md | 4 ++++ components.yaml | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d9bcc35bd9a5..7786f9603428 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,6 +31,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - The MAPL\_ESMFRegridder manage now does compute the transpose by default - Bypassed the I-Server reading call when there is no extdata +- Update `components.yaml` + - ESMA_cmake v3.42.0 + - Updates to MPI detection + - Enable `-quiet` flag for NAG ### Fixed diff --git a/components.yaml b/components.yaml index 4c63d816dee8..302dff5eeba7 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.40.0 + tag: v3.42.0 develop: develop ecbuild: From 2dc67bce04f4745b76cd49130eeba1f0c631c52a Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 18 Mar 2024 11:24:25 -0600 Subject: [PATCH 080/141] add gatherV for 3D field before writing to netCDF --- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 65 +++++++++++-------- 1 file changed, 38 insertions(+), 27 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 5c188e49bd23..0bad4912163b 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -20,7 +20,7 @@ use MAPL_StringTemplate use Plain_netCDF_Time use MAPL_ObsUtilMod - use MPI, only : MPI_REAL, MPI_DOUBLE_PRECISION, MPI_INTEGER + use MPI, only : MPI_REAL, MPI_REAL8, MPI_DOUBLE_PRECISION, MPI_INTEGER use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -133,7 +133,6 @@ enddo - ! __ s2. find nobs && distinguish design with vs wo '------' nobs=0 call ESMF_ConfigFindLabel( config, trim(string)//'obs_files:', _RC) @@ -143,6 +142,7 @@ if ( index(trim(STR1), '-----') > 0 ) nobs=nobs+1 enddo + ! __ s3. retrieve template and geoval, set metadata file_handle lgr => logging%get_logger('HISTORY.sampler') if ( nobs == 0 ) then @@ -169,7 +169,6 @@ nobs=0 ! reuse counter head=1 jvar=0 - ! ! count '------' in history.rc as special markers for ngeoval ! @@ -222,6 +221,7 @@ enddo end if + do k=1, traj%nobs_type allocate (traj%obs(k)%metadata, _STAT) if (mapl_am_i_root()) then @@ -229,6 +229,7 @@ end if end do + call lgr%debug('%a %i8', 'nobs_type=', traj%nobs_type) do i=1, traj%nobs_type call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & @@ -239,6 +240,7 @@ traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) end do + _RETURN(_SUCCESS) 105 format (1x,a,2x,a) @@ -246,6 +248,7 @@ end procedure HistoryTrajectory_from_config + ! !-- integrate both initialize and reinitialize ! @@ -403,7 +406,6 @@ !! 'Traj: create_metadata_variable: vname, var_name, this%obs(k)%geoval_xname(ig)', & !! trim(vname), trim(var_name), trim(this%obs(k)%geoval_xname(ig)) - endif enddo enddo @@ -863,10 +865,11 @@ na = int ( nx_sum / petCount ) ! base length nb = nx_sum - na * (petCount -1) ! exception if (mypet < petCount -1) then - recvcount = na + nx = na else - recvcount = nb + nx = nb end if + recvcount = nx allocate ( sendcount (petCount) ) allocate ( displs (petCount) ) sendcount ( 1:petCount-1 ) = na @@ -895,7 +898,7 @@ call MPI_Barrier(mpic, status) -!- test print out +!!- test print out ! write(6,'(2x,a,10i8)') 'ck mypet, nx, recvcount', & ! mypet, nx, recvcount ! write(6,'(2x,a,10i8)') 'sendcount', sendcount @@ -934,7 +937,7 @@ ! defer destroy fieldB at regen_grid step ! - !!_FAIL('nail 1') +!! _FAIL('nail 1: create_grid') _RETURN(_SUCCESS) end procedure create_grid @@ -1213,6 +1216,7 @@ end function extract_unquoted_item real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) + real(kind=REAL32), pointer :: p_dst_rt(:,:) type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field real(kind=REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) @@ -1224,11 +1228,14 @@ end function extract_unquoted_item integer :: j, k, ig integer, allocatable :: ix(:) type(ESMF_VM) :: vm - integer :: mypet, petcount, mpic + integer :: mypet, petcount, mpic, iroot integer :: na, nb, nx_sum, nsend - integer, allocatable :: RECVCOUNT(:), displs(:) - + integer, allocatable :: RecvCount(:), displs(:) + integer :: i, ierr + integer, allocatable :: nsend_v, recvcount_v(:), displs_v(:) + + if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) endif @@ -1280,6 +1287,7 @@ end function extract_unquoted_item call ESMF_VMGetCurrent(vm,_RC) call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) + iroot = 0 na = int ( nx_sum / petCount ) ! base length nb = nx_sum - na * (petCount -1) ! exception if (mypet /= petCount -1) then @@ -1295,7 +1303,7 @@ end function extract_unquoted_item do i = 2, petCount displs(i) = displs(i-1) + recvcount(i-1) end do - + iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1303,13 +1311,13 @@ end function extract_unquoted_item call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) call ESMF_FieldGet(acc_field,rank=rank,_RC) if (rank==1) then -!! if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:2d item%xname', trim(item%xname) - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC) - call ESMF_FieldGet( acc_field_2d_chunk, localDE=0, farrayPtr=p_acc_chunk_2d, _RC) - call ESMF_FieldRedist( acc_field, acc_field_2d_chunk, RH, _RC) - ! - ! call gatherV - + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC ) + call ESMF_FieldGet( acc_field_2d_chunk, localDE=0, farrayPtr=p_acc_chunk_2d, _RC ) + call ESMF_FieldRedist( acc_field, acc_field_2d_chunk, RH, _RC ) + allocate ( p_acc_rt_2d(nx_sum) ) + call MPI_gatherv ( p_acc_chunk_2d, nsend, MPI_REAL, & + p_acc_rt_2d, recvcount, displs, MPI_REAL,& + iroot, mpic, ierr ) if (mapl_am_i_root()) then ! @@ -1356,13 +1364,13 @@ end function extract_unquoted_item deallocate (this%obs(k)%p2d, _STAT) enddo end if - else if (rank==2) then - !!if( MAPL_AM_I_ROOT() ) write(6, '(2x,a,2x,a)') 'append:3d item%xname', trim(item%xname) - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) - call ESMF_FieldGet( acc_field_3d_chunk, localDE=0, farrayPtr=p_acc_chunk_3d, _RC) + nsend_v = nsend * lm + allocate (recvcount_v, source = recvcount * lm ) + allocate (displs_v, source = displs * lm ) + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) dst_field=ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4, & gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & @@ -1370,10 +1378,15 @@ end function extract_unquoted_item call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) - p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) - p_acc_chunk_3d=reshape(p_dst, shape(p_acc_chunk_3d), order=[2,1]) + + allocate ( p_acc_rt_3d(nx_sum,lm) ) + allocate ( p_dst_rt(lm, nx_sum) ) + call MPI_gatherv ( p_dst, nsend_v, MPI_REAL, & + p_dst_rt, recvcount_v, displs_v, MPI_REAL,& + iroot, mpic, ierr ) + p_acc_rt_3d = reshape ( p_dst_rt, shape(p_acc_rt_3d), order=[2,1] ) call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) @@ -1433,6 +1446,4 @@ end function extract_unquoted_item end procedure append_file - - end submodule HistoryTrajectory_implement From adcf4b9273480eb577e13800865a4d15cb3d09c6 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 18 Mar 2024 11:57:09 -0600 Subject: [PATCH 081/141] code cleanup --- CHANGELOG.md | 1 + base/MAPL_LocStreamFactoryMod.F90 | 18 +- .../History/Sampler/MAPL_EpochSwathMod.F90 | 15 +- .../History/Sampler/MAPL_TrajectoryMod.F90 | 4 +- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 528 +++++++++--------- 5 files changed, 277 insertions(+), 289 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7786f9603428..59cefa9aa9be 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Trajectory sampler: add locstream_chunk and MPI_gaththerV as an intermediate step between ls_rt and ls_distributed(bk=cs_grid) to save computational time - Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) - Give informative error message when swath grid Epoch does not equal swath sampler frequency - Add mask sampler for geostationary satellite (GEOS-R series) diff --git a/base/MAPL_LocStreamFactoryMod.F90 b/base/MAPL_LocStreamFactoryMod.F90 index 89bc14c42e2c..77a693bf00dd 100644 --- a/base/MAPL_LocStreamFactoryMod.F90 +++ b/base/MAPL_LocStreamFactoryMod.F90 @@ -20,8 +20,8 @@ module LocStreamFactoryMod real(kind=REAL64), allocatable :: lats(:) contains procedure :: create_locstream - procedure :: create_locstream_on_proc - procedure :: destroy_locstream + procedure :: create_locstream_on_proc + procedure :: destroy_locstream end type interface LocStreamFactory @@ -37,9 +37,9 @@ function LocStreamFactory_from_arrays(lons,lats,unusable,rc) result(factory) class (KeywordEnforcer), optional, intent(in) :: unusable integer, optional, intent(out) :: rc integer :: status - + _UNUSED_DUMMY(unusable) - + _ASSERT(size(lons)==size(lats),"Lats and Lons for locstream must be same size") allocate(factory%lons,source=lons,stat=status) _VERIFY(status) @@ -59,7 +59,7 @@ function create_locstream(this,unusable,grid,rc) result(locstream) integer :: my_pet,local_count,status real(kind=REAL64), allocatable :: tlons(:),tlats(:) - _UNUSED_DUMMY(unusable) + _UNUSED_DUMMY(unusable) call ESMF_VMGetCurrent(vm,rc=status) _VERIFY(status) call ESMF_VMGet(vm,localPet=my_pet,rc=status) @@ -132,13 +132,13 @@ subroutine destroy_locstream(this,locstream,rc) type(ESMF_LocStream) :: locstream integer, optional, intent(out) :: rc integer :: status - + if (allocated(this%lons)) deallocate (this%lons) if (allocated(this%lats)) deallocate (this%lats) call ESMF_LocStreamDestroy (locstream,noGarbage=.true.,_RC) - - _RETURN(_SUCCESS) + + _RETURN(_SUCCESS) end subroutine destroy_locstream - + end module LocStreamFactoryMod diff --git a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 index daa47ef388bd..0fb038bff536 100644 --- a/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 +++ b/gridcomps/History/Sampler/MAPL_EpochSwathMod.F90 @@ -30,6 +30,7 @@ module MAPL_EpochSwathMod use Plain_netCDF_Time use, intrinsic :: ISO_C_BINDING use MAPL_CommsMod, only : MAPL_Am_I_Root + use pflogger, only: Logger, logging implicit none private @@ -205,6 +206,7 @@ subroutine verify_epoch_equals_freq (this, frequency_from_list, swath_grid_label integer :: time_integer logical :: con integer :: status + type(Logger), pointer :: lgr call ESMF_TimeIntervalGet(this%Frequency_epoch, s=hq_epoch_sec, _RC) freq_sec = MAPL_nsecf( frequency_from_list ) @@ -213,14 +215,15 @@ subroutine verify_epoch_equals_freq (this, frequency_from_list, swath_grid_label label=trim(swath_grid_label)//'.Epoch:', default=0, _RC) local_swath_epoch_sec = MAPL_nsecf( time_integer ) + lgr => logging%get_logger('HISTORY.sampler') con = (hq_epoch_sec == local_swath_epoch_sec) .AND. (hq_epoch_sec == freq_sec) - if (mapl_am_i_root()) then - if (.not. con) then - write(6, '(2x,a,2x,i10)') 'hq_epoch_sec', hq_epoch_sec - write(6, '(2x,a,2x,i10)') 'local_swath_epoch_sec', local_swath_epoch_sec - write(6, '(2x,a,2x,i10)') 'freq_sec', freq_sec - end if + + if (.not. con) then + call lgr%debug('%a %i', 'hq_epoch_sec', hq_epoch_sec) + call lgr%debug('%a %i', 'local_swath_epoch_sec', local_swath_epoch_sec) + call lgr%debug('%a %i', 'freq_sec', freq_sec) end if + _ASSERT(con, 'Error in '//trim(swath_grid_label)//' related swath and list in History.rc: Epoch in all swath grids must be equal, and equal to list%freq') _RETURN(_SUCCESS) end subroutine verify_epoch_equals_freq diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 index 2f51ceb4c8db..8ae2e3da209f 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -17,7 +17,7 @@ module HistoryTrajectoryMod private type(ESMF_LocStream) :: LS_rt type(ESMF_LocStream) :: LS_ds - type(ESMF_LocStream) :: LS_chunk + type(ESMF_LocStream) :: LS_chunk type(LocStreamFactory) :: locstream_factory type(obs_unit), allocatable :: obs(:) type(ESMF_Time), allocatable :: times(:) @@ -25,7 +25,7 @@ module HistoryTrajectoryMod real(kind=REAL64), allocatable :: lats(:) real(kind=REAL64), allocatable :: times_R8(:) integer, allocatable :: obstype_id(:) - integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file + integer, allocatable :: location_index_ioda(:) ! location index in its own ioda file type(ESMF_FieldBundle) :: bundle type(ESMF_FieldBundle) :: output_bundle diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 0bad4912163b..35689807b369 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -20,7 +20,7 @@ use MAPL_StringTemplate use Plain_netCDF_Time use MAPL_ObsUtilMod - use MPI, only : MPI_REAL, MPI_REAL8, MPI_DOUBLE_PRECISION, MPI_INTEGER + use MPI, only : MPI_INTEGER, MPI_REAL, MPI_REAL8 use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 implicit none @@ -562,7 +562,7 @@ real(kind=REAL64), allocatable :: lons_chunk(:) real(kind=REAL64), allocatable :: lats_chunk(:) - real(kind=REAL64), allocatable :: times_R8_chunk(:) + real(kind=REAL64), allocatable :: times_R8_chunk(:) integer :: na, nb lgr => logging%get_logger('HISTORY.sampler') @@ -849,7 +849,7 @@ !__ s2. create LS on parallel processors ! caution about zero-sized array for MPI ! - + ! nx = int ( nx_sum / petCount ) ! each proc ! if (mypet == petCount -1) nx = nx_sum - nx * (petCount -1) ! reuse nx ! allocate ( sendcount (petCount) ) @@ -877,45 +877,32 @@ displs(1)=0 do i = 2, petCount displs(i) = displs(i-1) + sendcount(i-1) - end do + end do - allocate ( lons_chunk (nx) ) allocate ( lats_chunk (nx) ) - allocate ( times_R8_chunk (nx) ) + allocate ( times_R8_chunk (nx) ) call MPI_Scatterv( this%lons, sendcount, & - displs, MPI_DOUBLE_PRECISION, lons_chunk, & - recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) + displs, MPI_REAL8, lons_chunk, & + recvcount, MPI_REAL8, 0, mpic, ierr) call MPI_Scatterv( this%lats, sendcount, & - displs, MPI_DOUBLE_PRECISION, lats_chunk, & - recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) + displs, MPI_REAL8, lats_chunk, & + recvcount, MPI_REAL8, 0, mpic, ierr) call MPI_Scatterv( this%times_R8, sendcount, & - displs, MPI_DOUBLE_PRECISION, times_R8_chunk, & - recvcount, MPI_DOUBLE_PRECISION, 0, mpic, ierr) - - call MPI_Barrier(mpic, status) - -!!- test print out -! write(6,'(2x,a,10i8)') 'ck mypet, nx, recvcount', & -! mypet, nx, recvcount -! write(6,'(2x,a,10i8)') 'sendcount', sendcount -! write(6,'(2x,a,10i8)') 'displs', displs -! write(6,'(2x,a,2i8)') 'ck mypet, nx, lons_chunk(1:nx)',& -! mypet, nx -! write(6,'(10f10.2)') lons_chunk(1:nx) - - - ! -- root + displs, MPI_REAL8, times_R8_chunk, & + recvcount, MPI_REAL8, 0, mpic, ierr) + + ! -- root this%locstream_factory = LocStreamFactory(this%lons,this%lats,_RC) this%LS_rt = this%locstream_factory%create_locstream(_RC) ! -- proc this%locstream_factory = LocStreamFactory(lons_chunk,lats_chunk,_RC) this%LS_chunk = this%locstream_factory%create_locstream_on_proc(_RC) - + call ESMF_FieldBundleGet(this%bundle,grid=grid,_RC) this%LS_ds = this%locstream_factory%create_locstream_on_proc(grid=grid,_RC) @@ -930,19 +917,257 @@ call ESMF_FieldRedistStore (this%fieldA, this%fieldB, RH, _RC) call ESMF_FieldRedist (this%fieldA, this%fieldB, RH, _RC) - !!write(6,'(2x,a,i5,2x,10E20.11)') 'pet=', mypet, this%obsTime(1:10) - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) call ESMF_FieldDestroy(this%fieldA,nogarbage=.true.,_RC) ! defer destroy fieldB at regen_grid step ! - -!! _FAIL('nail 1: create_grid') _RETURN(_SUCCESS) end procedure create_grid + + module procedure append_file + type(GriddedIOitemVectorIterator) :: iter + type(GriddedIOitem), pointer :: item + type(ESMF_RouteHandle) :: RH + + type(ESMF_Field) :: src_field, dst_field + type(ESMF_Field) :: acc_field + type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt + real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) + real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) + real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) + real(kind=REAL32), pointer :: p_dst_rt(:,:) + + type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field + real(kind=REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) + + integer :: is, ie, nx + integer :: lm + integer :: rank + integer :: status + integer :: j, k, ig + integer, allocatable :: ix(:) + type(ESMF_VM) :: vm + integer :: mypet, petcount, mpic, iroot + + integer :: na, nb, nx_sum, nsend + integer, allocatable :: RecvCount(:), displs(:) + integer :: i, ierr + integer, allocatable :: nsend_v, recvcount_v(:), displs_v(:) + + + if (.NOT. this%active) then + _RETURN(ESMF_SUCCESS) + endif + + if (this%nobs_epoch_sum==0) then + rc=0 + return + endif + + is=1 + do k = 1, this%nobs_type + !-- limit nx < 2**32 (integer*4) + nx=this%obs(k)%nobs_epoch + if (nx >0) then + if (mapl_am_i_root()) then + call this%obs(k)%file_handle%put_var(this%var_name_time, real(this%obs(k)%times_R8), & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%var_name_lon, this%obs(k)%lons, & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & + start=[is], count=[nx], _RC) + call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & + start=[is], count=[nx], _RC) + end if + end if + enddo + + ! get RH from 2d field + src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + chunk_field = ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + call ESMF_FieldRedistStore(src_field,chunk_field,RH,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(chunk_field,noGarbage=.true.,_RC) + + ! redist and put_var + lm = this%vdata%lm + acc_field_2d_rt = ESMF_FieldCreate (this%LS_rt, name='field_2d_rt', typekind=ESMF_TYPEKIND_R4, _RC) + acc_field_3d_rt = ESMF_FieldCreate (this%LS_rt, name='field_3d_rt', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + acc_field_2d_chunk = ESMF_FieldCreate (this%LS_chunk, name='field_2d_chunk', typekind=ESMF_TYPEKIND_R4, _RC) + acc_field_3d_chunk = ESMF_FieldCreate (this%LS_chunk, name='field_3d_chunk', typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + ! + ! caution about zero-sized array for MPI + ! + nx_sum = this%nobs_epoch_sum + call ESMF_VMGetCurrent(vm,_RC) + call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) + + iroot = 0 + na = int ( nx_sum / petCount ) ! base length + nb = nx_sum - na * (petCount -1) ! exception + if (mypet /= petCount -1) then + nsend = na + else + nsend = nb + end if + allocate ( recvcount (petCount) ) + allocate ( displs (petCount) ) + recvcount ( 1:petCount-1 ) = na + recvcount ( petcount ) = nb + displs(1)=0 + do i = 2, petCount + displs(i) = displs(i-1) + recvcount(i-1) + end do + + iter = this%items%begin() + do while (iter /= this%items%end()) + item => iter%get() + if (item%itemType == ItemTypeScalar) then + call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) + call ESMF_FieldGet(acc_field,rank=rank,_RC) + if (rank==1) then + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC ) + call ESMF_FieldGet( acc_field_2d_chunk, localDE=0, farrayPtr=p_acc_chunk_2d, _RC ) + call ESMF_FieldRedist( acc_field, acc_field_2d_chunk, RH, _RC ) + allocate ( p_acc_rt_2d(nx_sum) ) + call MPI_gatherv ( p_acc_chunk_2d, nsend, MPI_REAL, & + p_acc_rt_2d, recvcount, displs, MPI_REAL,& + iroot, mpic, ierr ) + + if (mapl_am_i_root()) then + ! + !-- pack fields to obs(k)%p2d and put_var + ! + is=1 + ie=this%epoch_index(2)-this%epoch_index(1)+1 + do k=1, this%nobs_type + nx = this%obs(k)%nobs_epoch + allocate (this%obs(k)%p2d(nx), _STAT) + enddo + + allocate(ix(this%nobs_type), _STAT) + ix(:)=0 + do j=is, ie + k = this%obstype_id(j) + ix(k) = ix(k) + 1 + this%obs(k)%p2d(ix(k)) = p_acc_rt_2d(j) + enddo + + do k=1, this%nobs_type + if (ix(k) /= this%obs(k)%nobs_epoch) then + print*, 'obs_', k, ' : ix(k) /= this%obs(k)%nobs_epoch' + print*, 'obs_', k, ' : this%obs(k)%nobs_epoch, ix(k) =', this%obs(k)%nobs_epoch, ix(k) + _FAIL('test ix(k) failed') + endif + enddo + deallocate(ix, _STAT) + do k=1, this%nobs_type + is = 1 + nx = this%obs(k)%nobs_epoch + if (nx>0) then + do ig = 1, this%obs(k)%ngeoval + !!write(6,'(2x,a,2x,a)') 't this%obs(k)%geoval_xname(ig)', trim(this%obs(k)%geoval_xname(ig)) + if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then + !!write(6, '(2x,a,2x,a)') 'append:2d inner put_var item%xname', trim(item%xname) + call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & + start=[is],count=[nx]) + end if + enddo + endif + enddo + do k=1, this%nobs_type + deallocate (this%obs(k)%p2d, _STAT) + enddo + end if + + else if (rank==2) then + nsend_v = nsend * lm + allocate (recvcount_v, source = recvcount * lm ) + allocate (displs_v, source = displs * lm ) + + call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) + dst_field=ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & + gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) + + call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) + call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) + p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) + call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) + + allocate ( p_acc_rt_3d(nx_sum,lm) ) + allocate ( p_dst_rt(lm, nx_sum) ) + call MPI_gatherv ( p_dst, nsend_v, MPI_REAL, & + p_dst_rt, recvcount_v, displs_v, MPI_REAL,& + iroot, mpic, ierr ) + p_acc_rt_3d = reshape ( p_dst_rt, shape(p_acc_rt_3d), order=[2,1] ) + + call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) + call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + + if (mapl_am_i_root()) then + ! + !-- pack fields to obs(k)%p3d and put_var + ! + is=1 + ie=this%epoch_index(2)-this%epoch_index(1)+1 + do k=1, this%nobs_type + nx = this%obs(k)%nobs_epoch + allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2)), _STAT) + enddo + allocate(ix(this%nobs_type), _STAT) + ix(:)=0 + do j=is, ie + k = this%obstype_id(j) + ix(k) = ix(k) + 1 + this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) + enddo + deallocate(ix, _STAT) + do k=1, this%nobs_type + is = 1 + nx = this%obs(k)%nobs_epoch + if (nx>0) then + do ig = 1, this%obs(k)%ngeoval + if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then + !!write(6, '(2x,a,2x,a)') 'append:3d inner put_var item%xname', trim(item%xname) + call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & + start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + end if + end do + endif + enddo + !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) + !!write(6,*) 'here in append_file: put_var 3d' + !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& + !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) + !! + do k=1, this%nobs_type + deallocate (this%obs(k)%p3d, _STAT) + enddo + end if + endif + + else if (item%itemType == ItemTypeVector) then + _FAIL("ItemTypeVector not yet supported") + end if + call iter%next() + enddo + call ESMF_FieldDestroy(acc_field_2d_chunk, noGarbage=.true., _RC) + call ESMF_FieldDestroy(acc_field_3d_chunk, noGarbage=.true., _RC) + call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + + _RETURN(_SUCCESS) + end procedure append_file + + module procedure regrid_accumulate_on_xsubset integer :: x_subset(2) type(ESMF_Time) :: timeset(2) @@ -1205,245 +1430,4 @@ function extract_unquoted_item(string_list) result(item) end function extract_unquoted_item - module procedure append_file - type(GriddedIOitemVectorIterator) :: iter - type(GriddedIOitem), pointer :: item - type(ESMF_RouteHandle) :: RH - - type(ESMF_Field) :: src_field, dst_field - type(ESMF_Field) :: acc_field - type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt - real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) - real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) - real(kind=REAL32), pointer :: p_dst_rt(:,:) - - type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field - real(kind=REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) - - integer :: is, ie, nx - integer :: lm - integer :: rank - integer :: status - integer :: j, k, ig - integer, allocatable :: ix(:) - type(ESMF_VM) :: vm - integer :: mypet, petcount, mpic, iroot - - integer :: na, nb, nx_sum, nsend - integer, allocatable :: RecvCount(:), displs(:) - integer :: i, ierr - integer, allocatable :: nsend_v, recvcount_v(:), displs_v(:) - - - if (.NOT. this%active) then - _RETURN(ESMF_SUCCESS) - endif - - if (this%nobs_epoch_sum==0) then - rc=0 - return - endif - - is=1 - do k = 1, this%nobs_type - !-- limit nx < 2**32 (integer*4) - nx=this%obs(k)%nobs_epoch - if (nx >0) then - if (mapl_am_i_root()) then - call this%obs(k)%file_handle%put_var(this%var_name_time, real(this%obs(k)%times_R8), & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%var_name_lon, this%obs(k)%lons, & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%var_name_lat, this%obs(k)%lats, & - start=[is], count=[nx], _RC) - call this%obs(k)%file_handle%put_var(this%location_index_name, this%obs(k)%location_index_ioda, & - start=[is], count=[nx], _RC) - end if - end if - enddo - - ! get RH from 2d field - src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) - chunk_field = ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) - call ESMF_FieldRedistStore(src_field,chunk_field,RH,_RC) - call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - call ESMF_FieldDestroy(chunk_field,noGarbage=.true.,_RC) - - ! redist and put_var - lm = this%vdata%lm - acc_field_2d_rt = ESMF_FieldCreate (this%LS_rt, name='field_2d_rt', typekind=ESMF_TYPEKIND_R4, _RC) - acc_field_3d_rt = ESMF_FieldCreate (this%LS_rt, name='field_3d_rt', typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - acc_field_2d_chunk = ESMF_FieldCreate (this%LS_chunk, name='field_2d_chunk', typekind=ESMF_TYPEKIND_R4, _RC) - acc_field_3d_chunk = ESMF_FieldCreate (this%LS_chunk, name='field_3d_chunk', typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[1],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - ! - ! caution about zero-sized array for MPI - ! - nx_sum = this%nobs_epoch_sum - call ESMF_VMGetCurrent(vm,_RC) - call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) - - iroot = 0 - na = int ( nx_sum / petCount ) ! base length - nb = nx_sum - na * (petCount -1) ! exception - if (mypet /= petCount -1) then - nsend = na - else - nsend = nb - end if - allocate ( recvcount (petCount) ) - allocate ( displs (petCount) ) - recvcount ( 1:petCount-1 ) = na - recvcount ( petcount ) = nb - displs(1)=0 - do i = 2, petCount - displs(i) = displs(i-1) + recvcount(i-1) - end do - - iter = this%items%begin() - do while (iter /= this%items%end()) - item => iter%get() - if (item%itemType == ItemTypeScalar) then - call ESMF_FieldBundleGet(this%acc_bundle,trim(item%xname),field=acc_field,_RC) - call ESMF_FieldGet(acc_field,rank=rank,_RC) - if (rank==1) then - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC ) - call ESMF_FieldGet( acc_field_2d_chunk, localDE=0, farrayPtr=p_acc_chunk_2d, _RC ) - call ESMF_FieldRedist( acc_field, acc_field_2d_chunk, RH, _RC ) - allocate ( p_acc_rt_2d(nx_sum) ) - call MPI_gatherv ( p_acc_chunk_2d, nsend, MPI_REAL, & - p_acc_rt_2d, recvcount, displs, MPI_REAL,& - iroot, mpic, ierr ) - - if (mapl_am_i_root()) then - ! - !-- pack fields to obs(k)%p2d and put_var - ! - is=1 - ie=this%epoch_index(2)-this%epoch_index(1)+1 - do k=1, this%nobs_type - nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p2d(nx), _STAT) - enddo - - allocate(ix(this%nobs_type), _STAT) - ix(:)=0 - do j=is, ie - k = this%obstype_id(j) - ix(k) = ix(k) + 1 - this%obs(k)%p2d(ix(k)) = p_acc_rt_2d(j) - enddo - - do k=1, this%nobs_type - if (ix(k) /= this%obs(k)%nobs_epoch) then - print*, 'obs_', k, ' : ix(k) /= this%obs(k)%nobs_epoch' - print*, 'obs_', k, ' : this%obs(k)%nobs_epoch, ix(k) =', this%obs(k)%nobs_epoch, ix(k) - _FAIL('test ix(k) failed') - endif - enddo - deallocate(ix, _STAT) - do k=1, this%nobs_type - is = 1 - nx = this%obs(k)%nobs_epoch - if (nx>0) then - do ig = 1, this%obs(k)%ngeoval - !!write(6,'(2x,a,2x,a)') 't this%obs(k)%geoval_xname(ig)', trim(this%obs(k)%geoval_xname(ig)) - if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - !!write(6, '(2x,a,2x,a)') 'append:2d inner put_var item%xname', trim(item%xname) - call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & - start=[is],count=[nx]) - end if - enddo - endif - enddo - do k=1, this%nobs_type - deallocate (this%obs(k)%p2d, _STAT) - enddo - end if - - else if (rank==2) then - nsend_v = nsend * lm - allocate (recvcount_v, source = recvcount * lm ) - allocate (displs_v, source = displs * lm ) - - call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) - dst_field=ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - src_field=ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4, & - gridToFieldMap=[2],ungriddedLBound=[1],ungriddedUBound=[lm],_RC) - - call ESMF_FieldGet(src_field,localDE=0,farrayPtr=p_src,_RC) - call ESMF_FieldGet(dst_field,localDE=0,farrayPtr=p_dst,_RC) - p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) - call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) - - allocate ( p_acc_rt_3d(nx_sum,lm) ) - allocate ( p_dst_rt(lm, nx_sum) ) - call MPI_gatherv ( p_dst, nsend_v, MPI_REAL, & - p_dst_rt, recvcount_v, displs_v, MPI_REAL,& - iroot, mpic, ierr ) - p_acc_rt_3d = reshape ( p_dst_rt, shape(p_acc_rt_3d), order=[2,1] ) - - call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) - call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - - if (mapl_am_i_root()) then - ! - !-- pack fields to obs(k)%p3d and put_var - ! - is=1 - ie=this%epoch_index(2)-this%epoch_index(1)+1 - do k=1, this%nobs_type - nx = this%obs(k)%nobs_epoch - allocate (this%obs(k)%p3d(nx, size(p_acc_rt_3d,2)), _STAT) - enddo - allocate(ix(this%nobs_type), _STAT) - ix(:)=0 - do j=is, ie - k = this%obstype_id(j) - ix(k) = ix(k) + 1 - this%obs(k)%p3d(ix(k),:) = p_acc_rt_3d(j,:) - enddo - deallocate(ix, _STAT) - do k=1, this%nobs_type - is = 1 - nx = this%obs(k)%nobs_epoch - if (nx>0) then - do ig = 1, this%obs(k)%ngeoval - if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - !!write(6, '(2x,a,2x,a)') 'append:3d inner put_var item%xname', trim(item%xname) - call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & - start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - end if - end do - endif - enddo - !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) - !!write(6,*) 'here in append_file: put_var 3d' - !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& - !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - !! - do k=1, this%nobs_type - deallocate (this%obs(k)%p3d, _STAT) - enddo - end if - endif - - else if (item%itemType == ItemTypeVector) then - _FAIL("ItemTypeVector not yet supported") - end if - call iter%next() - enddo - call ESMF_FieldDestroy(acc_field_2d_chunk, noGarbage=.true., _RC) - call ESMF_FieldDestroy(acc_field_3d_chunk, noGarbage=.true., _RC) - call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - - _RETURN(_SUCCESS) - end procedure append_file - - end submodule HistoryTrajectory_implement From f6c7d4a8b1c6ff6753faed080644bf95ca5100da Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 18 Mar 2024 16:20:38 -0400 Subject: [PATCH 082/141] Add ESSENTIAL label --- .circleci/config.yml | 6 +++--- CHANGELOG.md | 6 +++++- Tests/ExtData_Testing_Framework/CMakeLists.txt | 16 +++++++++------- base/tests/CMakeLists.txt | 1 + components.yaml | 2 +- field_utils/tests/CMakeLists.txt | 1 + generic/tests/CMakeLists.txt | 1 + pfio/tests/CMakeLists.txt | 1 + profiler/tests/CMakeLists.txt | 3 ++- shared/tests/CMakeLists.txt | 1 + 10 files changed, 25 insertions(+), 13 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index b4dee0c83db0..936adf290499 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -39,7 +39,7 @@ workflows: repo: MAPL mepodevelop: false run_unit_tests: true - ctest_options: "-LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" + ctest_options: "-L 'ESSENTIAL' --output-on-failure" persist_workspace: true # Needed for MAPL tutorials # Builds MAPL in a "default" way - GNU @@ -65,7 +65,7 @@ workflows: repo: MAPL mepodevelop: false run_unit_tests: true - ctest_options: "-E bundleio -LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" + ctest_options: "-E bundleio -L 'ESSENTIAL' --output-on-failure" persist_workspace: true # Needed for MAPL tutorials # Builds MAPL like UFS does (no FLAP and pFlogger, static) @@ -83,7 +83,7 @@ workflows: remove_pflogger: true extra_cmake_options: "-DBUILD_WITH_FLAP=OFF -DBUILD_WITH_PFLOGGER=OFF -DBUILD_WITH_FARGPARSE=OFF -DUSE_EXTDATA2G=OFF -DBUILD_SHARED_MAPL=OFF" run_unit_tests: true - ctest_options: "-LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure" + ctest_options: "-L 'ESSENTIAL' --output-on-failure" # Run MAPL Tutorials - ci/run_mapl_tutorial: diff --git a/CHANGELOG.md b/CHANGELOG.md index 7786f9603428..2cb4018eba9b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -31,10 +31,14 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - The MAPL\_ESMFRegridder manage now does compute the transpose by default - Bypassed the I-Server reading call when there is no extdata +- Created new `ESSENTIAL` ctest label for tests that must pass for a release + - These are "simple" quick tests that don't require a lot of resources + - With ESMA_cmake v3.43.0, `make tests` will only run tests with the `ESSENTIAL` label. To run all tests, use `make tests-all` - Update `components.yaml` - - ESMA_cmake v3.42.0 + - ESMA_cmake v3.43.0 - Updates to MPI detection - Enable `-quiet` flag for NAG + - `make tests` now only runs tests with the `ESSENTIAL` label. To run all tests, use `make tests-all` ### Fixed diff --git a/Tests/ExtData_Testing_Framework/CMakeLists.txt b/Tests/ExtData_Testing_Framework/CMakeLists.txt index 257555524a4b..db2f9f97937c 100644 --- a/Tests/ExtData_Testing_Framework/CMakeLists.txt +++ b/Tests/ExtData_Testing_Framework/CMakeLists.txt @@ -17,9 +17,9 @@ foreach(TEST_CASE ${TEST_CASES_1G}) endif() add_test( NAME "ExtData1G_${TEST_CASE}" - COMMAND ${CMAKE_COMMAND} - -DTEST_CASE=${TEST_CASE} - -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} + COMMAND ${CMAKE_COMMAND} + -DTEST_CASE=${TEST_CASE} + -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG} -DMY_BINARY_DIR=${CMAKE_BINARY_DIR}/bin -DMPIEXEC_PREFLAGS=${MPIEXEC_PREFLAGS} @@ -28,6 +28,7 @@ foreach(TEST_CASE ${TEST_CASES_1G}) ) if (${num_procs} LESS ${cutoff}) set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_SMALL_TESTS") + set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "ESSENTIAL") else() set_tests_properties ("ExtData1G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA1G_BIG_TESTS") endif() @@ -37,7 +38,7 @@ endforeach() file(STRINGS "test_cases/extdata_2g_cases.txt" TEST_CASES_2G) foreach(TEST_CASE ${TEST_CASES_2G}) - + if (EXISTS ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc) file(READ ${CMAKE_CURRENT_LIST_DIR}/test_cases/${TEST_CASE}/nproc.rc num_procs) else() @@ -45,9 +46,9 @@ foreach(TEST_CASE ${TEST_CASES_2G}) endif() add_test( NAME "ExtData2G_${TEST_CASE}" - COMMAND ${CMAKE_COMMAND} - -DTEST_CASE=${TEST_CASE} - -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} + COMMAND ${CMAKE_COMMAND} + -DTEST_CASE=${TEST_CASE} + -DMPIEXEC_EXECUTABLE=${MPIEXEC_EXECUTABLE} -DMPIEXEC_NUMPROC_FLAG=${MPIEXEC_NUMPROC_FLAG} -DMY_BINARY_DIR=${CMAKE_BINARY_DIR}/bin -DMPIEXEC_PREFLAGS=${MPIEXEC_PREFLAGS} @@ -56,6 +57,7 @@ foreach(TEST_CASE ${TEST_CASES_2G}) ) if (${num_procs} LESS ${cutoff}) set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_SMALL_TESTS") + set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "ESSENTIAL") else() set_tests_properties ("ExtData2G_${TEST_CASE}" PROPERTIES LABELS "EXTDATA2G_BIG_TESTS") endif() diff --git a/base/tests/CMakeLists.txt b/base/tests/CMakeLists.txt index d246076f242f..c9d92ca17f7d 100644 --- a/base/tests/CMakeLists.txt +++ b/base/tests/CMakeLists.txt @@ -45,6 +45,7 @@ add_pfunit_ctest(MAPL.base.tests MAX_PES 8 ) set_target_properties(MAPL.base.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(MAPL.base.tests PROPERTIES LABELS "ESSENTIAL") add_dependencies(build-tests MAPL.base.tests) diff --git a/components.yaml b/components.yaml index 302dff5eeba7..044130166faa 100644 --- a/components.yaml +++ b/components.yaml @@ -11,7 +11,7 @@ ESMA_env: ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.42.0 + tag: v3.43.0 develop: develop ecbuild: diff --git a/field_utils/tests/CMakeLists.txt b/field_utils/tests/CMakeLists.txt index 196badeda463..6a9cf4d5520a 100644 --- a/field_utils/tests/CMakeLists.txt +++ b/field_utils/tests/CMakeLists.txt @@ -16,6 +16,7 @@ add_pfunit_ctest(MAPL.field_utils.tests MAX_PES 4 ) set_target_properties(MAPL.field_utils.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(MAPL.field_utils.tests PROPERTIES LABELS "ESSENTIAL") if (APPLE) set(LD_PATH "DYLD_LIBRARY_PATH") diff --git a/generic/tests/CMakeLists.txt b/generic/tests/CMakeLists.txt index 8b0ccc0a3ae8..debb627bf535 100644 --- a/generic/tests/CMakeLists.txt +++ b/generic/tests/CMakeLists.txt @@ -15,5 +15,6 @@ add_pfunit_ctest(MAPL.generic.tests MAX_PES 1 ) set_target_properties(MAPL.generic.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(MAPL.generic.tests PROPERTIES LABELS "ESSENTIAL") add_dependencies(build-tests MAPL.generic.tests) diff --git a/pfio/tests/CMakeLists.txt b/pfio/tests/CMakeLists.txt index ceaf974d8c7e..29fe0153030e 100644 --- a/pfio/tests/CMakeLists.txt +++ b/pfio/tests/CMakeLists.txt @@ -45,6 +45,7 @@ add_pfunit_ctest(MAPL.pfio.tests MAX_PES 8 ) set_target_properties(MAPL.pfio.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(MAPL.pfio.tests PROPERTIES LABELS "ESSENTIAL") include_directories( ${CMAKE_CURRENT_SOURCE_DIR} diff --git a/profiler/tests/CMakeLists.txt b/profiler/tests/CMakeLists.txt index d21da302558e..3046f73a458d 100644 --- a/profiler/tests/CMakeLists.txt +++ b/profiler/tests/CMakeLists.txt @@ -22,6 +22,7 @@ add_pfunit_ctest ( MAX_PES 8 ) set_target_properties(MAPL.profiler.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) - +set_tests_properties(MAPL.profiler.tests PROPERTIES LABELS "ESSENTIAL") + add_dependencies (build-tests MAPL.profiler.tests) diff --git a/shared/tests/CMakeLists.txt b/shared/tests/CMakeLists.txt index b9b167d082ca..4198dfdc8315 100644 --- a/shared/tests/CMakeLists.txt +++ b/shared/tests/CMakeLists.txt @@ -16,5 +16,6 @@ add_pfunit_ctest(MAPL.shared.tests LINK_LIBRARIES MAPL.shared ) set_target_properties(MAPL.shared.tests PROPERTIES Fortran_MODULE_DIRECTORY ${MODULE_DIRECTORY}) +set_tests_properties(MAPL.shared.tests PROPERTIES LABELS "ESSENTIAL") add_dependencies(build-tests MAPL.shared.tests) From 77458239cd97339eaf88237c4ffc479c75ba4c30 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 19 Mar 2024 14:09:32 -0600 Subject: [PATCH 083/141] initialize pt=0 for fields before `call ESMF_FieldRegridStore` in MAPL_LocstreamRegridder.F90 --- base/MAPL_LocstreamRegridder.F90 | 7 +++++++ .../History/Sampler/MAPL_TrajectoryMod_smod.F90 | 17 +++-------------- 2 files changed, 10 insertions(+), 14 deletions(-) diff --git a/base/MAPL_LocstreamRegridder.F90 b/base/MAPL_LocstreamRegridder.F90 index 75612f678107..bd16cb3a0c9e 100644 --- a/base/MAPL_LocstreamRegridder.F90 +++ b/base/MAPL_LocstreamRegridder.F90 @@ -40,6 +40,7 @@ function new_LocstreamRegridder(grid,locstream,unusable,regrid_method,rc) result type(ESMF_RegridMethod_Flag) :: local_regrid_method type(ESMF_Field) :: src_field, dst_field + real, pointer :: pt2d(:,:), pt1d(:) integer :: status _UNUSED_DUMMY(unusable) @@ -53,6 +54,12 @@ function new_LocstreamRegridder(grid,locstream,unusable,regrid_method,rc) result _VERIFY(status) dst_field = ESMF_FieldCreate(locstream,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],rc=status) _VERIFY(status) + + call ESMF_FieldGet(src_field, localDE=0, farrayPtr=pt2d, _RC) + call ESMF_FieldGet(dst_field, localDE=0, farrayPtr=pt1d, _RC) + pt2d = 0.0 + pt1d = 0.0 + call ESMF_FieldRegridStore(srcField=src_field,dstField=dst_field, & routeHandle=regridder%route_handle,regridmethod=local_regrid_method,rc=status) _VERIFY(status) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 35689807b369..85d0ce8c2768 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -850,19 +850,7 @@ ! caution about zero-sized array for MPI ! -! nx = int ( nx_sum / petCount ) ! each proc -! if (mypet == petCount -1) nx = nx_sum - nx * (petCount -1) ! reuse nx -! allocate ( sendcount (petCount) ) -! allocate ( displs (petCount) ) -! recvcount = nx -! sendcount ( 1:petCount-1 ) = int ( nx_sum / petCount ) -! sendcount ( petcount ) = nx_sum - int ( nx_sum / petCount ) * (petCount-1) -! displs(1)=0 -! do i = 2, petCount -! displs(i) = displs(i-1) + sendcount(i-1) -! end do - - na = int ( nx_sum / petCount ) ! base length + na = nx_sum / petCount ! base length nb = nx_sum - na * (petCount -1) ! exception if (mypet < petCount -1) then nx = na @@ -955,7 +943,8 @@ integer :: na, nb, nx_sum, nsend integer, allocatable :: RecvCount(:), displs(:) integer :: i, ierr - integer, allocatable :: nsend_v, recvcount_v(:), displs_v(:) + integer :: nsend_v + integer, allocatable :: recvcount_v(:), displs_v(:) if (.NOT. this%active) then From 9a15c61f33578bbbbd3f9bb335b6053354136e85 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 19 Mar 2024 15:18:21 -0600 Subject: [PATCH 084/141] initialize another field before calling ESMF_FieldRedistStore --- gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 85d0ce8c2768..a173f4b1b143 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -924,9 +924,10 @@ type(ESMF_Field) :: acc_field type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - real(kind=REAL32), pointer :: p_acc_rt_3d(:,:),p_acc_rt_2d(:) + real(kind=REAL32), pointer :: p_acc_rt_2d(:) real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) - real(kind=REAL32), pointer :: p_dst_rt(:,:) + real(kind=REAL32), allocatable :: p_dst_rt(:,:), p_acc_rt_3d(:,:) + real(kind=REAL32), pointer :: pt1(:), pt2(:) type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field real(kind=REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) @@ -977,6 +978,10 @@ ! get RH from 2d field src_field = ESMF_FieldCreate(this%LS_ds,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) chunk_field = ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4,gridToFieldMap=[1],_RC) + call ESMF_FieldGet( src_field, localDE=0, farrayPtr=pt1, _RC ) + call ESMF_FieldGet( chunk_field, localDE=0, farrayPtr=pt2, _RC ) + pt1=0.0 + pt2=0.0 call ESMF_FieldRedistStore(src_field,chunk_field,RH,_RC) call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) call ESMF_FieldDestroy(chunk_field,noGarbage=.true.,_RC) From 220b11ee92bfd97f1f3a12e0a6013f7d1a4d7549 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 20 Mar 2024 09:05:52 -0600 Subject: [PATCH 085/141] Use a better algorithm for nsend in mpi scatter --- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 54 +++++++++---------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index a173f4b1b143..33686dd23c83 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -559,12 +559,14 @@ integer, allocatable :: sendcount(:), displs(:) integer :: recvcount integer :: is, ie, ierr - + integer :: M, N, ip + integer :: na, nb + real(kind=REAL64), allocatable :: lons_chunk(:) real(kind=REAL64), allocatable :: lats_chunk(:) real(kind=REAL64), allocatable :: times_R8_chunk(:) - integer :: na, nb + lgr => logging%get_logger('HISTORY.sampler') call ESMF_VMGetCurrent(vm,_RC) @@ -848,28 +850,26 @@ !__ s1. distrubute data chunk for the locstream points : mpi_scatterV !__ s2. create LS on parallel processors ! caution about zero-sized array for MPI - ! - - na = nx_sum / petCount ! base length - nb = nx_sum - na * (petCount -1) ! exception - if (mypet < petCount -1) then - nx = na - else - nx = nb - end if - recvcount = nx + ! + ip = mypet + N = nx_sum + M = petCount + recvcount = int((ip+1)*N, kind=INT64)/M - int( ip*N, kind=INT64)/M +!! write(6,'(2x,a,2x,2i10)') 'ip, recvcount', ip, recvcount + allocate ( sendcount (petCount) ) allocate ( displs (petCount) ) - sendcount ( 1:petCount-1 ) = na - sendcount ( petcount ) = nb + do ip=0, M-1 + sendcount(ip+1) = int((ip+1)*N, kind=INT64)/M - int( ip*N, kind=INT64)/M + end do displs(1)=0 do i = 2, petCount displs(i) = displs(i-1) + sendcount(i-1) end do - - allocate ( lons_chunk (nx) ) - allocate ( lats_chunk (nx) ) - allocate ( times_R8_chunk (nx) ) + + allocate ( lons_chunk (recvcount) ) + allocate ( lats_chunk (recvcount) ) + allocate ( times_R8_chunk (recvcount) ) call MPI_Scatterv( this%lons, sendcount, & displs, MPI_REAL8, lons_chunk, & @@ -946,7 +946,7 @@ integer :: i, ierr integer :: nsend_v integer, allocatable :: recvcount_v(:), displs_v(:) - + integer :: ip, M, N if (.NOT. this%active) then _RETURN(ESMF_SUCCESS) @@ -1004,17 +1004,15 @@ call ESMF_VMGet(vm, mpiCommunicator=mpic, petCount=petCount, localPet=mypet, _RC) iroot = 0 - na = int ( nx_sum / petCount ) ! base length - nb = nx_sum - na * (petCount -1) ! exception - if (mypet /= petCount -1) then - nsend = na - else - nsend = nb - end if + ip = mypet + N = nx_sum + M = petCount + nsend = int((ip+1)*N, kind=INT64)/M - int( ip*N, kind=INT64)/M allocate ( recvcount (petCount) ) allocate ( displs (petCount) ) - recvcount ( 1:petCount-1 ) = na - recvcount ( petcount ) = nb + do ip=0, M-1 + recvcount(ip+1) = int((ip+1)*N, kind=INT64)/M - int(ip*N, kind=INT64)/M + end do displs(1)=0 do i = 2, petCount displs(i) = displs(i-1) + recvcount(i-1) From 98cb6de245da97237c4f205d2f3a32513b29199b Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Wed, 20 Mar 2024 12:52:28 -0600 Subject: [PATCH 086/141] WIP debug --- .../History/Sampler/MAPL_TrajectoryMod_smod.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 33686dd23c83..e9242e7d9bf7 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -560,7 +560,7 @@ integer :: recvcount integer :: is, ie, ierr integer :: M, N, ip - integer :: na, nb +! integer :: na, nb real(kind=REAL64), allocatable :: lons_chunk(:) real(kind=REAL64), allocatable :: lats_chunk(:) @@ -851,12 +851,12 @@ !__ s2. create LS on parallel processors ! caution about zero-sized array for MPI ! - ip = mypet + ip = mypet ! 0 to M-1 N = nx_sum M = petCount - recvcount = int((ip+1)*N, kind=INT64)/M - int( ip*N, kind=INT64)/M + recvcount = int((ip+1)*N, kind=INT64)/M - int(ip*N, kind=INT64)/M !! write(6,'(2x,a,2x,2i10)') 'ip, recvcount', ip, recvcount - + allocate ( sendcount (petCount) ) allocate ( displs (petCount) ) do ip=0, M-1 @@ -871,6 +871,11 @@ allocate ( lats_chunk (recvcount) ) allocate ( times_R8_chunk (recvcount) ) + arr(1) = recvcount + call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx2, & + count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) + _ASSERT( nx2 == nx_sum, 'Erorr in recvcount' ) + call MPI_Scatterv( this%lons, sendcount, & displs, MPI_REAL8, lons_chunk, & recvcount, MPI_REAL8, 0, mpic, ierr) From 5d079ae4cc921d466791fa131524bb2bd32ad8fb Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 20 Mar 2024 15:59:21 -0400 Subject: [PATCH 087/141] allow bundle arithmetic --- Tests/ExtDataRoot_GridComp.F90 | 60 ++++++++++++++++-- gridcomps/History/MAPL_HistoryGridComp.F90 | 72 ++++++++++++---------- 2 files changed, 95 insertions(+), 37 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index dcc86a07611b..dbba6661f03a 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -132,7 +132,11 @@ subroutine SetServices ( GC, RC ) units = 'na', & dims = vloc, & vlocation = MAPL_VLocationNone, _RC) - + call MAPL_AddExportSpec(GC, & + short_name='test_bundle', & + long_name='test', & + units='X', & + datatype=MAPL_BundleItem, _RC) call MAPL_GenericSetServices ( GC, _RC) @@ -162,7 +166,7 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) type(SyntheticFieldSupport), pointer :: synth => null() character(len=ESMF_MaxStr) :: key, keyVal type(MAPL_MetaComp), pointer :: MAPL - logical :: isPresent + logical :: isPresent, fill_bundle call ESMF_GridCompGet( GC, name=comp_name, config=CF, _RC ) call MAPL_GetObjectFromGC ( GC, MAPL, _RC ) @@ -177,6 +181,11 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) if (isPresent) then call ESMF_ConfigGetAttribute(cf,label='delay:',value=synth%delay,_RC) end if + fill_bundle=.false. + call ESMF_ConfigFIndLabel(cf,label='fill_bundle:',isPresent=isPresent,_RC) + if (isPresent) then + call ESMF_ConfigGetAttribute(cf,label='fill_bundle:',value=fill_bundle,_RC) + end if call ESMF_ConfigGetDim(cf,nrows,ncolumn,label="FILL_DEF::",rc=status) if (status==ESMF_SUCCESS) then @@ -198,6 +207,9 @@ SUBROUTINE Initialize_ ( GC, IMPORT, EXPORT, CLOCK, rc ) call MAPL_GenericInitialize ( GC, IMPORT, EXPORT, clock, _RC) call ForceAllocation(Export,_RC) + if (fill_bundle) then + call FillBundle(Export,_RC) + end if _RETURN(ESMF_SUCCESS) contains @@ -536,6 +548,7 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) real, pointer :: Exptr2(:,:), Exptr1(:) integer :: itemcount character(len=ESMF_MAXSTR), allocatable :: outNameList(:) + type(ESMF_StateItem_Flag), allocatable :: item_type(:) type(ESMF_Field) :: expf,farray(7) type(ESMF_State) :: pstate character(len=:), pointer :: fexpr @@ -550,7 +563,9 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) call ESMF_StateGet(outState,itemcount=itemCount,_RC) allocate(outNameList(itemCount),stat=status) _VERIFY(status) - call ESMF_StateGet(outState,itemNameList=outNameList,_RC) + allocate(item_type(itemCount),stat=status) + _VERIFY(status) + call ESMF_StateGet(outState,itemTypeList=item_type,itemNameList=outNameList,_RC) if (synth%on_tiles) then call MAPL_GetPointer(inState,exPtr1,'time',_RC) @@ -608,15 +623,48 @@ subroutine FillState(inState,outState,time,grid,Synth,rc) call ESMF_StateAdd(pstate,farray,_RC) do i=1,itemCount - call ESMF_StateGet(outState,trim(outNameList(i)),expf,_RC) - fexpr => synth%fillDefs%at(trim(outNameList(i))) - call MAPL_StateEval(pstate,fexpr,expf,_RC) + if (item_type(i) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(outState,trim(outNameList(i)),expf,_RC) + fexpr => synth%fillDefs%at(trim(outNameList(i))) + call MAPL_StateEval(pstate,fexpr,expf,_RC) + end if enddo _RETURN(ESMF_SUCCESS) end subroutine FillState + subroutine FillBundle(inState,rc) + + type(ESMF_State), intent(inout) :: inState + integer, optional, intent(out) :: rc + + integer :: status + integer :: itemcount,i + character(len=ESMF_MAXSTR), allocatable :: outNameList(:) + type(ESMF_StateItem_Flag), allocatable :: item_type(:) + type(ESMF_Field) :: field + type(ESMF_FieldBundle) :: bundle + + call ESMF_StateGet(InState,itemcount=itemCount,_RC) + allocate(outNameList(itemCount),stat=status) + _VERIFY(status) + allocate(item_type(itemCount),stat=status) + _VERIFY(status) + call ESMF_StateGet(InState,itemTypeList=item_type,itemNameList=outNameList,_RC) + + call ESMF_StateGet(InState,"test_bundle",bundle,_RC) + do i=1,itemCount + if (item_type(i) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(InState,trim(outNameList(i)),field,_RC) + call MAPL_FieldBundleAdd(bundle,field,_RC) + end if + enddo + + _RETURN(ESMF_SUCCESS) + + end subroutine FillBundle + subroutine CompareState(State1,State2,tol,rc) type(ESMF_State), intent(inout) :: State1 type(ESMF_State), intent(inout) :: State2 diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 96c53f6225e4..b5600147a101 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -277,8 +277,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) type(ESMF_TimeInterval) :: oneMonth, dur type(ESMF_TimeInterval) :: Frequency type(ESMF_Array) :: array - type(ESMF_Field) :: field - type(ESMF_Field) :: f + type(ESMF_Field) :: field,f_extra type(ESMF_Calendar) :: cal type(ESMF_Config) :: config type(ESMF_DELayout) :: layout @@ -1393,11 +1392,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) statelist(k) = list(n)%field_set%fields(2,m) deallocate( tmplist ) endif - else - if (index(list(n)%field_set%fields(1,m),'%') /= 0) then - call WRITE_PARALLEL('Can not do arithmetic expression with bundle item') - _FAIL('needs informative message') - end if + !else + !if (index(list(n)%field_set%fields(1,m),'%') /= 0) then + !call WRITE_PARALLEL('Can not do arithmetic expression with bundle item') + !_FAIL('needs informative message') + !end if end if enddo enddo @@ -1941,11 +1940,11 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) call MAPL_ExportStateGet(exptmp,list(n)%PExtraGridComp(m),parser_state,_RC) call MAPL_StateGet(parser_state,list(n)%PExtraFields(m),parser_field,_RC) call MAPL_AllocateCoupling(parser_field, _RC) - f = MAPL_FieldCreate(parser_field, name=list(n)%PExtraFields(m), _RC) + f_extra = MAPL_FieldCreate(parser_field, name=list(n)%PExtraFields(m), _RC) if (IntState%average(n)) then - call MAPL_StateAdd(IntState%CIM(N), f, _RC) + call MAPL_StateAdd(IntState%CIM(N), f_extra, _RC) else - call MAPL_StateAdd(IntState%GIM(N), f, _RC) + call MAPL_StateAdd(IntState%GIM(N), f_extra, _RC) end if end do @@ -2018,29 +2017,29 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) end if if (.not.list(n)%rewrite(m) .or.special_name /= BLANK ) then - f = MAPL_FieldCreate(field, name=alias_name, _RC) + f_extra = MAPL_FieldCreate(field, name=alias_name, _RC) else DoCopy=.True. - f = MAPL_FieldCreate(field, name=alias_name, DoCopy=DoCopy, _RC) + f_extra = MAPL_FieldCreate(field, name=alias_name, DoCopy=DoCopy, _RC) endif if (special_name /= BLANK) then if (special_name == 'MIN') then - call ESMF_AttributeSet(f, NAME='CPLFUNC', VALUE=MAPL_CplMin, _RC) + call ESMF_AttributeSet(f_extra, NAME='CPLFUNC', VALUE=MAPL_CplMin, _RC) else if (special_name == 'MAX') then - call ESMF_AttributeSet(f, NAME='CPLFUNC', VALUE=MAPL_CplMax, _RC) + call ESMF_AttributeSet(f_extra, NAME='CPLFUNC', VALUE=MAPL_CplMax, _RC) else if (special_name == 'ACCUMULATE') then - call ESMF_AttributeSet(f, NAME='CPLFUNC', VALUE=MAPL_CplAccumulate, _RC) + call ESMF_AttributeSet(f_extra, NAME='CPLFUNC', VALUE=MAPL_CplAccumulate, _RC) else call WRITE_PARALLEL("Functionality not supported yet") end if end if if (IntState%average(n)) then - call MAPL_StateAdd(IntState%CIM(N), f, _RC) + call MAPL_StateAdd(IntState%CIM(N), f_extra, _RC) ! borrow SPEC from FIELD ! modify SPEC to reflect accum/avg - call ESMF_FieldGet(f, name=short_name, grid=grid, _RC) + call ESMF_FieldGet(f_extra, name=short_name, grid=grid, _RC) call ESMF_AttributeGet(FIELD, NAME='DIMS', VALUE=DIMS, _RC) call ESMF_AttributeGet(FIELD, NAME='VLOCATION', VALUE=VLOCATION, _RC) @@ -2201,9 +2200,13 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) REFRESH = MAPL_nsecf(list(n)%acc_interval) AVGINT = MAPL_nsecf( list(n)%frequency ) - call ESMF_AttributeSet(F, NAME='REFRESH_INTERVAL', VALUE=REFRESH, _RC) - call ESMF_AttributeSet(F, NAME='AVERAGING_INTERVAL', VALUE=AVGINT, _RC) - call MAPL_StateAdd(IntState%GIM(N), f, _RC) + call ESMF_AttributeSet(F_extra, NAME='REFRESH_INTERVAL', VALUE=REFRESH, _RC) + call ESMF_AttributeSet(F_extra, NAME='AVERAGING_INTERVAL', VALUE=AVGINT, _RC) + block + character(len=128) :: ffname + call ESMF_FieldGet(f_extra,name=ffname) + end block + call MAPL_StateAdd(IntState%GIM(N), f_extra, _RC) endif @@ -2211,7 +2214,7 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) !--------------------------------------------------------------- if (associated(IntState%Regrid(n)%PTR)) then ! replace field with newly created fld on grid_out - field = MAPL_FieldCreate(f, grid_out, _RC) + field = MAPL_FieldCreate(f_extra, grid_out, _RC) ! add field to state_out call MAPL_StateAdd(IntState%Regrid(N)%PTR%state_out, & field, _RC) @@ -4747,7 +4750,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & do m=1,nfield call MAPL_ExportStateGet(exptmp,fields(2,m),state,_RC) - if (index(fields(1,m),'%') == 0) then + !if (index(fields(1,m),'%') == 0) then call checkIfStateHasField(state, fields(1,m), hasField, _RC) if (hasField) then iRealFields = iRealFields + 1 @@ -4759,11 +4762,11 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & rewrite(m)= .TRUE. tmpfields(m)= trim(fields(1,m)) end if - else - isBundle(m)=.true. - rewrite(m)= .FALSE. - tmpfields(m)= trim(fields(1,m)) - endif + !else + !isBundle(m)=.true. + !rewrite(m)= .FALSE. + !tmpfields(m)= trim(fields(1,m)) + !endif enddo @@ -4971,7 +4974,7 @@ subroutine MAPL_RunExpression(state,fields,tmpfields,rewrite,nfield,rc) do m=1,nfield if (rewrite(m)) then fname = trim(fields(3,m)) - call MAPL_StateGet(state,fname,field,_RC) + call MAPL_StateGet(state,fname,field,force_field=.true.,_RC) fexpr = tmpfields(m) call MAPL_StateEval(state,fexpr,field,_RC) end if @@ -5028,19 +5031,26 @@ subroutine MAPL_StateDestroy(State, RC) end subroutine MAPL_StateDestroy #endif - subroutine MAPL_StateGet(state,name,field,rc) + subroutine MAPL_StateGet(state,name,field,force_field,rc) type(ESMF_State), intent(in) :: state character(len=*), intent(in) :: name type(ESMF_Field), intent(inout) :: field + logical, optional, intent(in) :: force_field integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: bundlename, fieldname type(ESMF_FieldBundle) :: bundle - + logical :: local_force_field integer :: i - i = index(name,"%") + if (present(force_field)) then + local_force_field = force_field + else + local_force_field = .false. + end if + i = 0 + if (.not.local_force_field) i = index(name,"%") if (i.ne.0) then bundlename = name(:i-1) fieldname = name(i+1:) From 396e66d67e90b209d4f82d8f4c9849569a716a9d Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 21 Mar 2024 08:30:05 -0400 Subject: [PATCH 088/141] Fixes #2663 - port to nag 7.201 Subtle. --- gridcomps/MAPL_GridComps.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/gridcomps/MAPL_GridComps.F90 b/gridcomps/MAPL_GridComps.F90 index 1e413ef4296a..a44ad5e84beb 100644 --- a/gridcomps/MAPL_GridComps.F90 +++ b/gridcomps/MAPL_GridComps.F90 @@ -1,6 +1,5 @@ module MAPL_GridCompsMod use mapl_CapMod - use mapl_CapOptionsMod use mapl_externalGCStorage #ifdef USE_FLAP use mapl_FlapCLIMod @@ -8,5 +7,6 @@ module MAPL_GridCompsMod #ifdef USE_FARGPARSE use mapl_FargParseCLIMod #endif + use mapl_CapOptionsMod implicit none end module MAPL_GridCompsMod From 43eefefc909f605e13181c44a6255b1bfa576da5 Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 21 Mar 2024 08:33:03 -0400 Subject: [PATCH 089/141] Forgot CHANGELOG. --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7eb05aea36da..2e58d1363327 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Fixed +- Minor workaround to enable NAG 7.2.01 to compile. (Reproducer submitted to NAG.) - Fixed bug with split restart files - Removed unnecessary memory allocation for tile reads. This is critical for high res runs on SCU17 - Fixes to allow SCM model to run From 01e92e41d648e487f010218c51c82e338df9b46e Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Thu, 21 Mar 2024 09:03:18 -0400 Subject: [PATCH 090/141] Undoing old workaround that now breaks intel. --- docs/tutorial/driver_app/Example_Driver.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/docs/tutorial/driver_app/Example_Driver.F90 b/docs/tutorial/driver_app/Example_Driver.F90 index b967506b94c0..f974d002a624 100644 --- a/docs/tutorial/driver_app/Example_Driver.F90 +++ b/docs/tutorial/driver_app/Example_Driver.F90 @@ -5,7 +5,6 @@ program Example_Driver use MPI use MAPL - use mapl_CapOptionsMod, only: MAPL_CapOptions implicit none type (MAPL_Cap) :: cap From 803388e56cc9f5be149fd1cfbaa146aa7737554c Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Thu, 21 Mar 2024 12:03:39 -0400 Subject: [PATCH 091/141] Add DEPENDS_ON & DEPENDS_ON_CHILDREN ACG Options --- Apps/MAPL_GridCompSpecs_ACG.py | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/Apps/MAPL_GridCompSpecs_ACG.py b/Apps/MAPL_GridCompSpecs_ACG.py index 0d2a80f19045..d14f497a2d35 100755 --- a/Apps/MAPL_GridCompSpecs_ACG.py +++ b/Apps/MAPL_GridCompSpecs_ACG.py @@ -49,8 +49,12 @@ def make_entry_emit(dictionary): 'REQ' : 'MAPL_RestartRequired', 'BOOT' : 'MAPL_RestartBoot', 'SKIPI': 'MAPL_RestartSkipInitial'}) +# emit function for logical-valued functions +LOGICAL_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) # emit function for Option.ADD2EXPORT -ADD2EXPORT_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) +ADD2EXPORT_EMIT = LOGICAL_EMIT +# emit function for OPTION.DEPENDS_ON_CHILDREN +DEPENDS_CHILDREN_EMIT = LOGICAL_EMIT # parent class for class Option # defines a few methods @@ -89,6 +93,8 @@ def get_mandatory_options(cls): 'AVINT': ('averaging_interval',), 'DATATYPE': ('datatype',), 'DEFAULT': ('default',), + 'DEPENDS_ON_CHILDREN': ('depends_on_children', DEPENDS_CHILDREN_EMIT), + 'DEPENDS_ON': ('depends_on', string_emit), 'FIELD_TYPE': ('field_type',), 'FRIENDLYTO': ('friendlyto', string_emit), 'FRIEND2': ('friendlyto', string_emit), From 7e24292ad0b626943735e1d9f835463c0297c415 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Mar 2024 12:01:38 -0400 Subject: [PATCH 092/141] one fix --- gridcomps/History/MAPL_HistoryGridComp.F90 | 47 +++++++++++++++++----- 1 file changed, 37 insertions(+), 10 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 3177410aec1a..0440a7060a51 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -5188,30 +5188,57 @@ subroutine RecordRestart( gc, import, export, clock, rc ) _RETURN(ESMF_SUCCESS) end subroutine RecordRestart - subroutine checkIfStateHasField(state, fieldName, hasField, rc) + subroutine checkIfStateHasField(state, input_fieldName, hasField, rc) type(ESMF_State), intent(in) :: state ! export state - character(len=*), intent(in) :: fieldName + character(len=*), intent(in) :: input_fieldName logical, intent(out) :: hasField integer, intent(out), optional :: rc ! Error code: - integer :: n, i, status + integer :: n, i, status, p_index character (len=ESMF_MAXSTR), allocatable :: itemNameList(:) type(ESMF_StateItem_Flag), allocatable :: itemTypeList(:) + character(len=:),allocatable :: field_name,bundle_name + logical :: is_bundle,isPresent + type(ESMF_FieldBundle) :: bundle call ESMF_StateGet(state, itemcount=n, _RC) allocate(itemNameList(n), _STAT) allocate(itemTypeList(n), _STAT) call ESMF_StateGet(state,itemnamelist=itemNamelist,itemtypelist=itemTypeList,_RC) + p_index = index(input_fieldName,"%") + if (p_index/=0) then + is_bundle = .true. + bundle_name = input_fieldName(1:p_index-1) + field_name = input_fieldName(p_index+1:) + else + is_bundle = .false. + field_name = input_fieldName + end if hasField = .false. - do I=1,N - if(itemTypeList(I)/=ESMF_STATEITEM_FIELD) cycle - if(itemNameList(I)==fieldName) then - hasField = .true. - exit - end if - end do + if (is_bundle) then + do I=1,N + if(itemTypeList(I)/=ESMF_STATEITEM_FIELDBUNDLE) cycle + if(itemNameList(I)==bundle_name) then + call ESMF_StateGet(state,bundle_name,bundle,_RC) + call ESMF_FieldBundleGet(bundle,field_name,isPresent=isPresent,_RC) + if (isPresent) then + hasField = .true. + exit + end if + end if + end do + + else + do I=1,N + if(itemTypeList(I)/=ESMF_STATEITEM_FIELD) cycle + if(itemNameList(I)==field_name) then + hasField = .true. + exit + end if + end do + end if deallocate(itemNameList, _STAT) deallocate(itemTypeList, _STAT) From 63f7434c8061af528cf38bbc0545aa246ed0a95f Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Mar 2024 15:49:23 -0400 Subject: [PATCH 093/141] redo check if field in state --- gridcomps/History/MAPL_HistoryGridComp.F90 | 34 +++++++--------------- 1 file changed, 11 insertions(+), 23 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 0440a7060a51..0749da2c0411 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -4778,7 +4778,6 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & type(ESMF_State) :: state type(ESMF_Field) :: field integer :: dims - logical, allocatable :: isBundle(:) logical :: hasField ! Set rewrite flag and tmpfields. @@ -4792,28 +4791,18 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & ! check which fields are actual exports or expressions nPExtraFields = 0 iRealFields = 0 - allocate(isBundle(nfield)) do m=1,nfield call MAPL_ExportStateGet(exptmp,fields(2,m),state,_RC) - !if (index(fields(1,m),'%') == 0) then - call checkIfStateHasField(state, fields(1,m), hasField, _RC) - if (hasField) then - iRealFields = iRealFields + 1 - rewrite(m)= .FALSE. - isBundle(m) = .FALSE. - tmpfields(m)= trim(fields(1,m)) - else - isBundle(m) = .false. - rewrite(m)= .TRUE. - tmpfields(m)= trim(fields(1,m)) - end if - !else - !isBundle(m)=.true. - !rewrite(m)= .FALSE. - !tmpfields(m)= trim(fields(1,m)) - !endif - + call checkIfStateHasField(state, fields(1,m), hasField, _RC) + if (hasField) then + iRealFields = iRealFields + 1 + rewrite(m)= .FALSE. + tmpfields(m)= trim(fields(1,m)) + else + rewrite(m)= .TRUE. + tmpfields(m)= trim(fields(1,m)) + end if enddo ! now that we know this allocated a place to store the names of the real fields @@ -4821,7 +4810,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & allocate(VarNeeded(iRealFields),_STAT) k=0 do m=1,nfield - if ( (rewrite(m) .eqv. .False.) .and. (isBundle(m) .eqv. .False.) ) then + if ( (rewrite(m) .eqv. .False.)) then k=k+1 VarNames(k)=fields(3,m) endif @@ -4907,7 +4896,7 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & iRealFields = 0 do i=1,nfield - if ( (.not.rewrite(i)) .and. (.not.isBundle(i)) ) then + if ( (.not.rewrite(i)) ) then iRealFields = iRealFields + 1 TotVarNames(iRealFields) = trim(fields(1,i)) TotCmpNames(iRealFields) = trim(fields(2,i)) @@ -4998,7 +4987,6 @@ subroutine MAPL_SetExpression(nfield,fields,tmpfields,rewrite,nPExtraFields, & deallocate(TotAliasNames) deallocate(TotRank) deallocate(TotLoc) - deallocate(isBundle) _RETURN(ESMF_SUCCESS) From e2bec93fa7e0ee7973deb3ef0a5332f66e1b4933 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Fri, 22 Mar 2024 16:34:44 -0400 Subject: [PATCH 094/141] Added and tested depends options --- Apps/MAPL_GridCompSpecs_ACG.py | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/Apps/MAPL_GridCompSpecs_ACG.py b/Apps/MAPL_GridCompSpecs_ACG.py index d14f497a2d35..695c2089ded2 100755 --- a/Apps/MAPL_GridCompSpecs_ACG.py +++ b/Apps/MAPL_GridCompSpecs_ACG.py @@ -28,6 +28,7 @@ string_emit = lambda value: ("'" + value + "'") if value else None # Return value in brackets array_emit = lambda value: ('[' + value + ']') if value else None +lstripped = lambda s: s.lower().strip(' .') mangle_name = lambda name: string_emit(name.replace("*","'//trim(comp_name)//'")) if name else None make_internal_name = lambda name: name.replace('*','') if name else None @@ -50,9 +51,14 @@ def make_entry_emit(dictionary): 'SKIPI': 'MAPL_RestartSkipInitial'}) # emit function for logical-valued functions -LOGICAL_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) +TRUEVALUES = {'t', 'true', 'yes', 'y', 'si', 'oui', 'sim'} +FALSEVALUES = {'f', 'false', 'no', 'n', 'no', 'non', 'nao'} +TRUE_VALUE = '.true.' +FALSE_VALUE = '.false.' +LOGICAL_EMIT = lambda s: TRUE_VALUE if lstripped(s) in TRUEVALUES else FALSE_VALUE if lstripped(s) in FALSEVALUES else None + # emit function for Option.ADD2EXPORT -ADD2EXPORT_EMIT = LOGICAL_EMIT +ADD2EXPORT_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) # emit function for OPTION.DEPENDS_ON_CHILDREN DEPENDS_CHILDREN_EMIT = LOGICAL_EMIT From 985a83e9158c8a6a593f7715b1493c1c816ea4dd Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Mar 2024 16:36:57 -0400 Subject: [PATCH 095/141] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 7eb05aea36da..aff1ba617f24 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Allow arithmetic operations to be performed on fields from bundles in History - Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) - Give informative error message when swath grid Epoch does not equal swath sampler frequency - Add mask sampler for geostationary satellite (GEOS-R series) From c7718aecaa17d1fc3a6bf30feb5afb0690e593f9 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Mar 2024 16:49:00 -0400 Subject: [PATCH 096/141] updates to extdatadriver.x --- Tests/ExtDataRoot_GridComp.F90 | 11 ++++----- Tests/VarspecDescription.F90 | 43 ++++++++++++---------------------- 2 files changed, 20 insertions(+), 34 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index dbba6661f03a..424e6a359be6 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -658,6 +658,10 @@ subroutine FillBundle(inState,rc) if (item_type(i) == ESMF_STATEITEM_FIELD) then call ESMF_StateGet(InState,trim(outNameList(i)),field,_RC) call MAPL_FieldBundleAdd(bundle,field,_RC) + block + integer:: myrank + call ESMF_FieldGet(field,rank=myrank,_RC) + end block end if enddo @@ -757,12 +761,7 @@ subroutine ForceAllocation(state,rc) do ii=1,itemCount if (itemTypeList(ii)==ESMF_STATEITEM_FIELD) then call ESMF_StateGet(State,trim(nameList(ii)),field,_RC) - call ESMF_AttributeGet(field,name='DIMS',value=dims,_RC) - if (dims==MAPL_DimsHorzOnly) then - call MAPL_GetPointer(state,ptr2d,trim(nameList(ii)),alloc=.true.,_RC) - else if (dims==MAPL_DimsHorzVert) then - call MAPL_GetPointer(state,ptr3d,trim(nameList(ii)),alloc=.true.,_RC) - end if + call MAPL_AllocateCoupling(field,_RC) end if enddo _RETURN(ESMF_SUCCESS) diff --git a/Tests/VarspecDescription.F90 b/Tests/VarspecDescription.F90 index 499a81d5a9e8..f2708a5926a5 100644 --- a/Tests/VarspecDescription.F90 +++ b/Tests/VarspecDescription.F90 @@ -38,6 +38,7 @@ function new_VarspecDescriptionFromConfig(cf,nwords,rc) result(VarspecDescr) type(StringVector) :: svec integer :: i + integer, pointer :: ungrid_ptr(:) character(ESMF_MAXSTR) :: tmpstring do i=1,nwords @@ -47,7 +48,7 @@ function new_VarspecDescriptionFromConfig(cf,nwords,rc) result(VarspecDescr) call svec%push_back(trim(tmpstring)) enddo - lcomp = (svec%size()==5 .or. svec%size()==7) + lcomp = (svec%size()==5 .or. svec%size()==6) _ASSERT(lcomp) VarspecDescr%short_name = svec%at(1) VarspecDescr%long_name = svec%at(2) @@ -68,29 +69,13 @@ function new_VarspecDescriptionFromConfig(cf,nwords,rc) result(VarspecDescr) else if (trim(tmpstring) == 'e') then VarspecDescr%location = MAPL_VLocationEdge end if - - if (svec%size() == 7) then + if (svec%size() == 6) then tmpstring = svec%at(6) - if (trim(tmpstring)== 'agrid') then - VarspecDescr%staggering = MAPL_AGrid - else if (trim(tmpstring)== 'cgrid') then - VarspecDescr%staggering = MAPL_CGrid - else if (trim(tmpstring)== 'dgrid') then - VarspecDescr%staggering = MAPL_DGrid - end if - - tmpstring = svec%at(7) - if (trim(tmpstring)== 'grid_aligned') then - VarspecDescr%rotation = MAPL_RotateCube - else if (trim(tmpstring)== 'latlon_aligned') then - VarspecDescr%rotation = MAPL_RotateLL - end if - - else - VarspecDescr%staggering = MAPL_AGrid - VarspecDescr%rotation = MAPL_AGrid + allocate(ungrid_ptr(1)) + read(tmpstring,*)ungrid_ptr(1) + if (ungrid_ptr(1) > 0) VarspecDescr%ungridded_dims => ungrid_ptr end if - + end function new_VarspecDescriptionFromConfig @@ -99,7 +84,7 @@ subroutine addNewSpec(this,gc,specType,rc) type(ESMF_GridComp), intent(inout) :: gc character(*), intent(in) :: specType integer, optional, intent(out) :: rc - + integer :: status character(len=*), parameter :: Iam = "addNewSpec" @@ -110,8 +95,9 @@ subroutine addNewSpec(this,gc,specType,rc) UNITS = this%units, & DIMS = this%dims, & VLOCATION = this%location, & - STAGGERING = this%staggering, & - ROTATION = this%rotation, & + !STAGGERING = this%staggering, & + !ROTATION = this%rotation, & + UNGRIDDED_DIMS = this%ungridded_dims, & RC = status) else if (specType == "EXPORT") then call MAPL_AddExportSpec(GC, & @@ -120,8 +106,9 @@ subroutine addNewSpec(this,gc,specType,rc) UNITS = this%units, & DIMS = this%dims, & VLOCATION = this%location, & - STAGGERING = this%staggering, & - ROTATION = this%rotation, & + !STAGGERING = this%staggering, & + !ROTATION = this%rotation, & + UNGRIDDED_DIMS = this%ungridded_dims, & RC = status) else _RETURN(_FAILURE) @@ -140,6 +127,6 @@ module VarspecDescriptionVectorMod #define _vector VarspecDescriptionVector #define _iterator VarspecDescriptionVectorIterator #include "templates/vector.inc" - + end module VarspecDescriptionVectorMod From cdf2854358033fe6d9a001877f17ba553ea22420 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Mar 2024 16:50:17 -0400 Subject: [PATCH 097/141] update changelog --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index aff1ba617f24..0d1774617dfc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Allow fields with ungridded dimension and bundles to be created in ExtDataDriver.x - Allow arithmetic operations to be performed on fields from bundles in History - Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) - Give informative error message when swath grid Epoch does not equal swath sampler frequency From 05cfd4eea910ff64332f03ee983b6b94c3b175de Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Fri, 22 Mar 2024 16:51:30 -0400 Subject: [PATCH 098/141] remove unused code --- Tests/ExtDataRoot_GridComp.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 424e6a359be6..9636b9184923 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -658,10 +658,6 @@ subroutine FillBundle(inState,rc) if (item_type(i) == ESMF_STATEITEM_FIELD) then call ESMF_StateGet(InState,trim(outNameList(i)),field,_RC) call MAPL_FieldBundleAdd(bundle,field,_RC) - block - integer:: myrank - call ESMF_FieldGet(field,rank=myrank,_RC) - end block end if enddo From ecb9f45f12c559dfbd71cfa67b1303d426d55f34 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 25 Mar 2024 12:45:43 -0400 Subject: [PATCH 099/141] fix test --- Tests/ExtDataRoot_GridComp.F90 | 38 +++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 17 deletions(-) diff --git a/Tests/ExtDataRoot_GridComp.F90 b/Tests/ExtDataRoot_GridComp.F90 index 9636b9184923..38504a9da6e6 100644 --- a/Tests/ExtDataRoot_GridComp.F90 +++ b/Tests/ExtDataRoot_GridComp.F90 @@ -498,36 +498,40 @@ subroutine CopyState(inState,outState,rc) integer :: itemcountIn,itemCountOut,rank character(len=ESMF_MAXSTR), allocatable :: inNameList(:) character(len=ESMF_MAXSTR), allocatable :: outNameList(:) + type(ESMF_StateItem_Flag), allocatable :: item_type_in(:) type(ESMF_Field) :: expf,impf call ESMF_StateGet(inState,itemcount=itemCountIn,_RC) allocate(InNameList(itemCountIn),stat=status) _VERIFY(status) - call ESMF_StateGet(inState,itemNameList=InNameList,_RC) + allocate(item_type_in(itemCountIn),stat=status) + _VERIFY(status) + call ESMF_StateGet(inState,itemNameList=InNameList,itemTypeList=item_type_in,_RC) call ESMF_StateGet(outState,itemcount=ItemCountOut,_RC) allocate(outNameList(ItemCountOut),stat=status) _VERIFY(status) call ESMF_StateGet(outState,itemNameList=outNameList,_RC) - _ASSERT(itemCountIn == itemCountOut,'needs informative message') call ESMF_StateGet(inState,itemNameList=inNameList,_RC) do i=1,itemCountIn - call ESMF_StateGet(inState,trim(inNameList(i)),impf,_RC) - call ESMF_StateGet(outState,trim(outNameList(i)),expf,_RC) - call ESMF_FieldGet(impf,rank=rank,_RC) - if (rank==1) then - call MAPL_GetPointer(inState,IMptr1,inNameList(i),_RC) - call MAPL_GetPointer(outState,Exptr1,inNameList(i),alloc=.true.,_RC) - EXptr1=IMptr1 - else if (rank==2) then - call MAPL_GetPointer(inState,IMptr2,inNameList(i),_RC) - call MAPL_GetPointer(outState,Exptr2,inNameList(i),alloc=.true.,_RC) - EXptr2=IMptr2 - else if (rank==3) then - call MAPL_GetPointer(inState,IMptr3,inNameList(i),_RC) - call MAPL_GetPointer(outState,EXptr3,inNameList(i),alloc=.true.,_RC) - EXptr3=IMptr3 + if (item_type_in(i) == ESMF_STATEITEM_FIELD) then + call ESMF_StateGet(inState,trim(inNameList(i)),impf,_RC) + call ESMF_StateGet(outState,trim(inNameList(i)),expf,_RC) + call ESMF_FieldGet(impf,rank=rank,_RC) + if (rank==1) then + call MAPL_GetPointer(inState,IMptr1,inNameList(i),_RC) + call MAPL_GetPointer(outState,Exptr1,inNameList(i),alloc=.true.,_RC) + EXptr1=IMptr1 + else if (rank==2) then + call MAPL_GetPointer(inState,IMptr2,inNameList(i),_RC) + call MAPL_GetPointer(outState,Exptr2,inNameList(i),alloc=.true.,_RC) + EXptr2=IMptr2 + else if (rank==3) then + call MAPL_GetPointer(inState,IMptr3,inNameList(i),_RC) + call MAPL_GetPointer(outState,EXptr3,inNameList(i),alloc=.true.,_RC) + EXptr3=IMptr3 + end if end if end do deallocate(inNameList,outNameList) From 8aa6c7af78222905d28e69583b10b2387455c9e4 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 25 Mar 2024 11:21:50 -0600 Subject: [PATCH 100/141] add ifdef level by level when gatherV 3D fields to root --- CHANGELOG.md | 2 +- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 75 ++++++++++++++----- 2 files changed, 58 insertions(+), 19 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 59cefa9aa9be..57d96d47c958 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Trajectory sampler: add locstream_chunk and MPI_gaththerV as an intermediate step between ls_rt and ls_distributed(bk=cs_grid) to save computational time +- Trajectory sampler: ls_rt -> ls_chunk (via mpi_gatherV) -> ls_distributed(bk=cs_grid; via ESMF_FieldRedistStore), aiming to save computational time. To gather 3D data via mpi, options for level by level and single-3D are added via ifdef. - Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) - Give informative error message when swath grid Epoch does not equal swath sampler frequency - Add mask sampler for geostationary satellite (GEOS-R series) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index e9242e7d9bf7..85210d5179eb 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -560,8 +560,8 @@ integer :: recvcount integer :: is, ie, ierr integer :: M, N, ip -! integer :: na, nb - + + real(kind=REAL64), allocatable :: lons_chunk(:) real(kind=REAL64), allocatable :: lats_chunk(:) real(kind=REAL64), allocatable :: times_R8_chunk(:) @@ -850,23 +850,26 @@ !__ s1. distrubute data chunk for the locstream points : mpi_scatterV !__ s2. create LS on parallel processors ! caution about zero-sized array for MPI - ! + ! ip = mypet ! 0 to M-1 N = nx_sum M = petCount - recvcount = int((ip+1)*N, kind=INT64)/M - int(ip*N, kind=INT64)/M + recvcount = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) + !! write(6,'(2x,a,2x,2i10)') 'ip, recvcount', ip, recvcount allocate ( sendcount (petCount) ) allocate ( displs (petCount) ) do ip=0, M-1 - sendcount(ip+1) = int((ip+1)*N, kind=INT64)/M - int( ip*N, kind=INT64)/M + sendcount(ip+1) = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) end do displs(1)=0 do i = 2, petCount displs(i) = displs(i-1) + sendcount(i-1) end do - + allocate ( lons_chunk (recvcount) ) allocate ( lats_chunk (recvcount) ) allocate ( times_R8_chunk (recvcount) ) @@ -875,7 +878,7 @@ call ESMF_VMAllFullReduce(vm, sendData=arr, recvData=nx2, & count=1, reduceflag=ESMF_REDUCE_SUM, rc=rc) _ASSERT( nx2 == nx_sum, 'Erorr in recvcount' ) - + call MPI_Scatterv( this%lons, sendcount, & displs, MPI_REAL8, lons_chunk, & recvcount, MPI_REAL8, 0, mpic, ierr) @@ -930,8 +933,8 @@ type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) real(kind=REAL32), pointer :: p_acc_rt_2d(:) - real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:) - real(kind=REAL32), allocatable :: p_dst_rt(:,:), p_acc_rt_3d(:,:) + real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:), p_dst_t(:,:) ! _t: transpose + real(kind=REAL32), pointer :: p_dst_rt(:,:), p_acc_rt_3d(:,:) real(kind=REAL32), pointer :: pt1(:), pt2(:) type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field @@ -1012,17 +1015,45 @@ ip = mypet N = nx_sum M = petCount - nsend = int((ip+1)*N, kind=INT64)/M - int( ip*N, kind=INT64)/M + nsend = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) allocate ( recvcount (petCount) ) allocate ( displs (petCount) ) do ip=0, M-1 - recvcount(ip+1) = int((ip+1)*N, kind=INT64)/M - int(ip*N, kind=INT64)/M + recvcount(ip+1) = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & + int(ip , INT64) * int(N, INT64) / int(M, INT64) end do displs(1)=0 do i = 2, petCount displs(i) = displs(i-1) + recvcount(i-1) end do + nsend_v = nsend * lm ! vertical + allocate (recvcount_v, source = recvcount * lm ) + allocate (displs_v, source = displs * lm ) + + if (mapl_am_i_root()) then + allocate ( p_acc_rt_2d(nx_sum) ) + else + allocate ( p_acc_rt_2d(1) ) + end if + ! + ! p_dst (lm, nx) + if (mapl_am_i_root()) then + allocate ( p_acc_rt_3d(nx_sum,lm) ) + allocate ( p_dst_rt(lm, nx_sum) ) + else + allocate ( p_acc_rt_3d(1,lm) ) + allocate ( p_dst_rt(lm, 1) ) + end if + +#define lev_b_lev 1 +#if defined(lev_b_lev) + if (mapl_am_i_root()) write(6,*) 'lev b lev: gatherV ls_chunk to ls_root' +#else + if (mapl_am_i_root()) write(6,*) '3d: gatherV ls_chunk to ls_root' +#endif + iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1033,7 +1064,6 @@ call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_2d, _RC ) call ESMF_FieldGet( acc_field_2d_chunk, localDE=0, farrayPtr=p_acc_chunk_2d, _RC ) call ESMF_FieldRedist( acc_field, acc_field_2d_chunk, RH, _RC ) - allocate ( p_acc_rt_2d(nx_sum) ) call MPI_gatherv ( p_acc_chunk_2d, nsend, MPI_REAL, & p_acc_rt_2d, recvcount, displs, MPI_REAL,& iroot, mpic, ierr ) @@ -1083,11 +1113,8 @@ deallocate (this%obs(k)%p2d, _STAT) enddo end if - else if (rank==2) then - nsend_v = nsend * lm - allocate (recvcount_v, source = recvcount * lm ) - allocate (displs_v, source = displs * lm ) + if (mapl_am_i_root()) write(6,*) 'in append rank=2, bg gatherv' call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) dst_field=ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4, & @@ -1100,16 +1127,27 @@ p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) - allocate ( p_acc_rt_3d(nx_sum,lm) ) - allocate ( p_dst_rt(lm, nx_sum) ) +#if defined(lev_b_lev) + ! p_dst (lm, nx) + allocate ( p_dst_t, source = reshape ( p_dst, [size(p_dst,2),size(p_dst,1)], order=[2,1] ) ) + do k = 1, lm + call MPI_gatherv ( p_dst_t(1,k), nsend, MPI_REAL, & + p_acc_rt_3d(1,k), recvcount, displs, MPI_REAL,& + iroot, mpic, ierr ) + end do + deallocate (p_dst_t) +#else call MPI_gatherv ( p_dst, nsend_v, MPI_REAL, & p_dst_rt, recvcount_v, displs_v, MPI_REAL,& iroot, mpic, ierr ) p_acc_rt_3d = reshape ( p_dst_rt, shape(p_acc_rt_3d), order=[2,1] ) +#endif call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) + if (mapl_am_i_root()) write(6,*) 'in append rank=2, af gatherv' + if (mapl_am_i_root()) then ! !-- pack fields to obs(k)%p3d and put_var @@ -1161,6 +1199,7 @@ call ESMF_FieldDestroy(acc_field_3d_chunk, noGarbage=.true., _RC) call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) + _RETURN(_SUCCESS) end procedure append_file From 7c487f8ccd18484200f2552cd9bd92127512f0b9 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 25 Mar 2024 13:41:45 -0400 Subject: [PATCH 101/141] LOGICAL_EMIT->logical_emit; simple depends option --- Apps/MAPL_GridCompSpecs_ACG.py | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/Apps/MAPL_GridCompSpecs_ACG.py b/Apps/MAPL_GridCompSpecs_ACG.py index 695c2089ded2..1a650fcc7d68 100755 --- a/Apps/MAPL_GridCompSpecs_ACG.py +++ b/Apps/MAPL_GridCompSpecs_ACG.py @@ -50,17 +50,15 @@ def make_entry_emit(dictionary): 'REQ' : 'MAPL_RestartRequired', 'BOOT' : 'MAPL_RestartBoot', 'SKIPI': 'MAPL_RestartSkipInitial'}) -# emit function for logical-valued functions +# emit function for logical-valued options TRUEVALUES = {'t', 'true', 'yes', 'y', 'si', 'oui', 'sim'} FALSEVALUES = {'f', 'false', 'no', 'n', 'no', 'non', 'nao'} TRUE_VALUE = '.true.' FALSE_VALUE = '.false.' -LOGICAL_EMIT = lambda s: TRUE_VALUE if lstripped(s) in TRUEVALUES else FALSE_VALUE if lstripped(s) in FALSEVALUES else None +logical_emit = lambda s: TRUE_VALUE if lstripped(s) in TRUEVALUES else FALSE_VALUE if lstripped(s) in FALSEVALUES else None # emit function for Option.ADD2EXPORT ADD2EXPORT_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) -# emit function for OPTION.DEPENDS_ON_CHILDREN -DEPENDS_CHILDREN_EMIT = LOGICAL_EMIT # parent class for class Option # defines a few methods @@ -99,7 +97,7 @@ def get_mandatory_options(cls): 'AVINT': ('averaging_interval',), 'DATATYPE': ('datatype',), 'DEFAULT': ('default',), - 'DEPENDS_ON_CHILDREN': ('depends_on_children', DEPENDS_CHILDREN_EMIT), + 'DEPENDS_ON_CHILDREN': ('depends_on_children', logical_emit), 'DEPENDS_ON': ('depends_on', string_emit), 'FIELD_TYPE': ('field_type',), 'FRIENDLYTO': ('friendlyto', string_emit), From 811d121da092fae5c95566ef9428e3e0908d3e66 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Mon, 25 Mar 2024 14:58:55 -0400 Subject: [PATCH 102/141] remove block that was for debugging --- gridcomps/History/MAPL_HistoryGridComp.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/gridcomps/History/MAPL_HistoryGridComp.F90 b/gridcomps/History/MAPL_HistoryGridComp.F90 index 0749da2c0411..4eaf29f21c46 100644 --- a/gridcomps/History/MAPL_HistoryGridComp.F90 +++ b/gridcomps/History/MAPL_HistoryGridComp.F90 @@ -2204,10 +2204,6 @@ subroutine Initialize ( gc, import, dumexport, clock, rc ) AVGINT = MAPL_nsecf( list(n)%frequency ) call ESMF_AttributeSet(F_extra, NAME='REFRESH_INTERVAL', VALUE=REFRESH, _RC) call ESMF_AttributeSet(F_extra, NAME='AVERAGING_INTERVAL', VALUE=AVGINT, _RC) - block - character(len=128) :: ffname - call ESMF_FieldGet(f_extra,name=ffname) - end block call MAPL_StateAdd(IntState%GIM(N), f_extra, _RC) endif From e612ee8374f807d1d76659744f17babafc7a70f0 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Mon, 25 Mar 2024 16:49:52 -0400 Subject: [PATCH 103/141] Update CHANGELOG.md --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2e58d1363327..ba30093ff006 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,6 +26,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Add python utilities to split and recombine restarts - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer - Implemented a new algorthm to read tile files +- Added two options, depends_on and depends_on_children, to ACG ### Changed From 3c1c1c0483e15e274aa0dc14ed3427a3b2004aa2 Mon Sep 17 00:00:00 2001 From: Darian Boggs Date: Wed, 27 Mar 2024 12:54:31 -0400 Subject: [PATCH 104/141] Add support for field names in quotes --- Apps/MAPL_GridCompSpecs_ACG.py | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/Apps/MAPL_GridCompSpecs_ACG.py b/Apps/MAPL_GridCompSpecs_ACG.py index 1a650fcc7d68..7e1c36c154af 100755 --- a/Apps/MAPL_GridCompSpecs_ACG.py +++ b/Apps/MAPL_GridCompSpecs_ACG.py @@ -30,6 +30,25 @@ array_emit = lambda value: ('[' + value + ']') if value else None lstripped = lambda s: s.lower().strip(' .') +# emit function for character arrays +string_array_emit = lambda value: make_string_array(value) if value else None + +def make_string_array(s): + """ Returns a string representing a Fortran character array """ + ss = s.strip() + if ',' in ss: + ls = [s.strip() for s in s.strip().split(',')] + else: + ls = s.strip().split() + ls = [rm_quotes(s) for s in ls] + ls = [s for s in ls if s] + n = max(ls) + ss = ','.join([add_quotes(s) for s in ls]) + return f"[character(len={n}) :: {ss}]" + +rm_quotes = lambda s: s.strip().strip('"\'').strip() +add_quotes = lambda s: "'" + s + "'" + mangle_name = lambda name: string_emit(name.replace("*","'//trim(comp_name)//'")) if name else None make_internal_name = lambda name: name.replace('*','') if name else None @@ -56,7 +75,6 @@ def make_entry_emit(dictionary): TRUE_VALUE = '.true.' FALSE_VALUE = '.false.' logical_emit = lambda s: TRUE_VALUE if lstripped(s) in TRUEVALUES else FALSE_VALUE if lstripped(s) in FALSEVALUES else None - # emit function for Option.ADD2EXPORT ADD2EXPORT_EMIT = make_entry_emit({'T': '.true.', 'F': '.false.'}) @@ -98,7 +116,7 @@ def get_mandatory_options(cls): 'DATATYPE': ('datatype',), 'DEFAULT': ('default',), 'DEPENDS_ON_CHILDREN': ('depends_on_children', logical_emit), - 'DEPENDS_ON': ('depends_on', string_emit), + 'DEPENDS_ON': ('depends_on', string_array_emit), 'FIELD_TYPE': ('field_type',), 'FRIENDLYTO': ('friendlyto', string_emit), 'FRIEND2': ('friendlyto', string_emit), From c06886d475e87d89f3fee8d52f1a6d147a359ad5 Mon Sep 17 00:00:00 2001 From: Benjamin Auer Date: Wed, 27 Mar 2024 15:55:17 -0400 Subject: [PATCH 105/141] changes needed for R21C --- griddedio/GriddedIO.F90 | 9 +++++++++ pfio/Variable.F90 | 7 +++++++ 2 files changed, 16 insertions(+) diff --git a/griddedio/GriddedIO.F90 b/griddedio/GriddedIO.F90 index cea3383893fe..b7582842887c 100644 --- a/griddedio/GriddedIO.F90 +++ b/griddedio/GriddedIO.F90 @@ -126,6 +126,7 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr integer :: metadataVarsSize type(StringStringMapIterator) :: s_iter character(len=:), pointer :: attr_name, attr_val + class(Variable), pointer :: coord_var integer :: status this%items = items @@ -155,6 +156,14 @@ subroutine CreateFileMetaData(this,items,bundle,timeInfo,vdata,ogrid,global_attr factory => get_factory(this%output_grid,rc=status) _VERIFY(status) call factory%append_metadata(this%metadata) + coord_var => this%metadata%get_variable('lons') + if (associated(coord_var)) call coord_var%set_deflation(this%deflateLevel) + coord_var => this%metadata%get_variable('lats') + if (associated(coord_var)) call coord_var%set_deflation(this%deflateLevel) + coord_var => this%metadata%get_variable('corner_lons') + if (associated(coord_var)) call coord_var%set_deflation(this%deflateLevel) + coord_var => this%metadata%get_variable('corner_lats') + if (associated(coord_var)) call coord_var%set_deflation(this%deflateLevel) if (present(vdata)) then this%vdata=vdata diff --git a/pfio/Variable.F90 b/pfio/Variable.F90 index 170ec8088da0..6bedd8c6043b 100644 --- a/pfio/Variable.F90 +++ b/pfio/Variable.F90 @@ -49,6 +49,7 @@ module pFIO_VariableMod procedure :: get_chunksizes procedure :: get_deflation + procedure :: set_deflation procedure :: get_quantize_algorithm procedure :: get_quantize_level procedure :: is_attribute_present @@ -282,6 +283,12 @@ function get_deflation(this) result(deflateLevel) deflateLevel=this%deflation end function get_deflation + subroutine set_deflation(this,deflate_level) + class (Variable), target, intent(inout) :: this + integer, intent(in) :: deflate_level + this%deflation = deflate_level + end subroutine + function get_quantize_algorithm(this) result(quantizeAlgorithm) class (Variable), target, intent(In) :: this integer :: quantizeAlgorithm From 18362778dd1a3d51a9855440a34ebbfcc35eadb9 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 28 Mar 2024 08:57:58 -0400 Subject: [PATCH 106/141] Update changelog --- .circleci/config.yml | 108 ++----------------------------------------- CHANGELOG.md | 8 +++- 2 files changed, 12 insertions(+), 104 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index b9ee045f4865..2c91163110d9 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -97,7 +97,8 @@ workflows: baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - mepodevelop: true + fixture_branch: R21C + mepodevelop: false checkout_mapl_branch: true persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day @@ -116,43 +117,10 @@ workflows: baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true - mepodevelop: true - checkout_mapl_branch: true - persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day - - # Build GEOSldas on ifort - - ci/build: - name: build-GEOSldas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - baselibs_version: *baselibs_version - repo: GEOSldas - mepodevelop: false - checkout_fixture: true - fixture_branch: develop - checkout_mapl_branch: true - - # Build GEOSldas on gfortran -- only to main - - ci/build: - filters: - branches: - only: - - main - name: build-GEOSldas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [gfortran] - baselibs_version: *baselibs_version - repo: GEOSldas + fixture_branch: R21C mepodevelop: false - checkout_fixture: true - fixture_branch: develop checkout_mapl_branch: true + persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day # Build GEOSadas (ifort only, needs a couple develop branches) -- only to main - ci/build: @@ -170,9 +138,7 @@ workflows: baselibs_version: *baselibs_version repo: GEOSadas checkout_fixture: true - # This branch on GEOSadas will be used to track subrepos needed - # for GEOSadas + MAPL develop much like how we do with MAPL 3 - fixture_branch: feature/mathomp4/mapldevelop + fixture_branch: R21C checkout_mapl_branch: true mepodevelop: false rebuild_procs: 1 @@ -214,67 +180,3 @@ workflows: bcs_version: *bcs_version gcm_ocean_type: MOM6 change_layout: false - - # Run MAPL Tutorials -- only to main - - ci/run_mapl_tutorial: - filters: - branches: - only: - - main - name: run-<< matrix.tutorial_name >>-Tutorial-with-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - #compiler: [gfortran, ifort] - compiler: [ifort] - tutorial_name: - - hello_world - - parent_no_children - - parent_one_child_import_via_extdata - - parent_one_child_no_imports - - parent_two_siblings_connect_import_export - # We will only run the tutorials with GNU make. No need to double up - # as Ninja is a build test only - requires: - - build-and-test-MAPL-on-<< matrix.compiler >>-using-Unix Makefiles - baselibs_version: *baselibs_version - - build-and-publish-docker: - when: - equal: [ "release", << pipeline.parameters.GHA_Event >> ] - jobs: - - ci/publish-docker: - filters: - tags: - only: /^v.*$/ - name: publish-intel-docker-image - context: - - docker-hub-creds - - ghcr-creds - os_version: *os_version - baselibs_version: *baselibs_version - container_name: mapl - mpi_name: intelmpi - mpi_version: 2021.6.0 - compiler_name: intel - compiler_version: 2022.1.0 - image_name: geos-env - tag_build_arg_name: *tag_build_arg_name - - ci/publish-docker: - filters: - tags: - only: /^v.*$/ - name: publish-gcc-docker-image - context: - - docker-hub-creds - - ghcr-creds - os_version: *os_version - baselibs_version: *baselibs_version - container_name: mapl - mpi_name: openmpi - mpi_version: 4.1.4 - compiler_name: gcc - compiler_version: 12.1.0 - image_name: geos-env-mkl - tag_build_arg_name: *tag_build_arg_name diff --git a/CHANGELOG.md b/CHANGELOG.md index 3ed000a48219..22ae8a1e7f87 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,7 +17,13 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Deprecated -## [2.35.4] - 2023-07-11 +## [v2.35.3+R21C_v1.1.0] - 2024-03-28 + +### Fixed + +- Fix inconsistency in History output so that multi-dimensional coordinate variables are also compressed if requested in the collection + +## [v2.35.3+R21C_v1.0.0] - 2024-02-16 ### Fixed From 56056b1276c1cacac93005154ddaec9d1336bfe9 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 28 Mar 2024 11:11:35 -0600 Subject: [PATCH 107/141] updates --- CHANGELOG.md | 2 +- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 40 ++++++++----------- 2 files changed, 17 insertions(+), 25 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e0e5572a5023..a82a5ad150f9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Trajectory sampler: ls_rt -> ls_chunk (via mpi_gatherV) -> ls_distributed(bk=cs_grid; via ESMF_FieldRedistStore), aiming to save computational time. To gather 3D data via mpi, options for level by level and single-3D are added via ifdef. - Allow fields with ungridded dimension and bundles to be created in ExtDataDriver.x - Allow arithmetic operations to be performed on fields from bundles in History - Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) @@ -32,6 +31,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Trajectory sampler: ls_rt -> ls_chunk (via mpi_gatherV) -> ls_distributed(bk=cs_grid; via ESMF_FieldRedistStore), aiming to save computational time. To gather 3D data via mpi, options for level by level and single-3D are added via ifdef. - The MAPL\_ESMFRegridder manage now does compute the transpose by default - Bypassed the I-Server reading call when there is no extdata - Update `components.yaml` diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 85210d5179eb..d227a79f3602 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -524,9 +524,9 @@ character(len=ESMF_MAXSTR) :: timeunits_file character :: new_char(ESMF_MAXSTR) - real(kind=REAL64), allocatable :: lons_full(:), lats_full(:) - real(kind=REAL64), allocatable :: times_R8_full(:) - real(kind=REAL64) :: t_shift + real(REAL64), allocatable :: lons_full(:), lats_full(:) + real(REAL64), allocatable :: times_R8_full(:) + real(REAL64) :: t_shift integer, allocatable :: obstype_id_full(:) integer, allocatable :: location_index_ioda_full(:) integer, allocatable :: IA_full(:) @@ -561,10 +561,9 @@ integer :: is, ie, ierr integer :: M, N, ip - - real(kind=REAL64), allocatable :: lons_chunk(:) - real(kind=REAL64), allocatable :: lats_chunk(:) - real(kind=REAL64), allocatable :: times_R8_chunk(:) + real(REAL64), allocatable :: lons_chunk(:) + real(REAL64), allocatable :: lats_chunk(:) + real(REAL64), allocatable :: times_R8_chunk(:) lgr => logging%get_logger('HISTORY.sampler') @@ -931,14 +930,14 @@ type(ESMF_Field) :: src_field, dst_field type(ESMF_Field) :: acc_field type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt - real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) - real(kind=REAL32), pointer :: p_acc_rt_2d(:) - real(kind=REAL32), pointer :: p_src(:,:),p_dst(:,:), p_dst_t(:,:) ! _t: transpose - real(kind=REAL32), pointer :: p_dst_rt(:,:), p_acc_rt_3d(:,:) - real(kind=REAL32), pointer :: pt1(:), pt2(:) + real(REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) + real(REAL32), pointer :: p_acc_rt_2d(:) + real(REAL32), pointer :: p_src(:,:),p_dst(:,:), p_dst_t(:,:) ! _t: transpose + real(REAL32), pointer :: p_dst_rt(:,:), p_acc_rt_3d(:,:) + real(REAL32), pointer :: pt1(:), pt2(:) type(ESMF_Field) :: acc_field_2d_chunk, acc_field_3d_chunk, chunk_field - real(kind=REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) + real(REAL32), pointer :: p_acc_chunk_3d(:,:),p_acc_chunk_2d(:) integer :: is, ie, nx integer :: lm @@ -1047,13 +1046,6 @@ allocate ( p_dst_rt(lm, 1) ) end if -#define lev_b_lev 1 -#if defined(lev_b_lev) - if (mapl_am_i_root()) write(6,*) 'lev b lev: gatherV ls_chunk to ls_root' -#else - if (mapl_am_i_root()) write(6,*) '3d: gatherV ls_chunk to ls_root' -#endif - iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1213,10 +1205,10 @@ type(GriddedIOitem), pointer :: item type(ESMF_Field) :: src_field,dst_field,acc_field integer :: rank - real(kind=REAL32), allocatable :: p_new_lev(:,:,:) - real(kind=REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) - real(kind=REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) - real(kind=REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) + real(REAL32), allocatable :: p_new_lev(:,:,:) + real(REAL32), pointer :: p_src_3d(:,:,:),p_src_2d(:,:) + real(REAL32), pointer :: p_dst_3d(:,:),p_dst_2d(:) + real(REAL32), pointer :: p_acc_3d(:,:),p_acc_2d(:) type(ESMF_VM) :: vm integer :: mypet, petcount integer :: is, ie, nx_sum From f5af102974f2420fff916bec6f6fc54d48842208 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Thu, 28 Mar 2024 11:16:47 -0600 Subject: [PATCH 108/141] fixed a typo --- gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index d227a79f3602..ff9d50691a11 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -1046,6 +1046,7 @@ allocate ( p_dst_rt(lm, 1) ) end if +#define lev_b_lev 1 iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() From a7a60cd79c7c450f6748f60ddf5a5879df9a9d5e Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 1 Apr 2024 10:36:19 -0400 Subject: [PATCH 109/141] Update to ESMA_cmake v3.44.0, ESMA_env v4.25.1 --- CHANGELOG.md | 7 ++++++- components.yaml | 4 ++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f902088d0916..d06d983896a2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,7 +16,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Add mask sampler for geostationary satellite (GEOS-R series) - Add geostation name into NC for station sampler - Add mapping between the IODA loc_index and trajectory NC output loc_index -- Add allocate(X, _STAT) to sampler codes +- Add `allocate(X, _STAT)` to sampler codes - Skip destroy_regen_grid when list(n)%end_alarm is active (the last time step in sampler) - Add extract_unquoted_item(STR1) to fix a bug in geoval_xname(mx_ngeoval) in trajectory sampler - Add `if (compute_transpose)` to sub. destroy_route_handle to avoid destroying a nonexisting route handle @@ -42,6 +42,11 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Updates to MPI detection - Enable `-quiet` flag for NAG - `make tests` now only runs tests with the `ESSENTIAL` label. To run all tests, use `make tests-all` + - `BUILT_ON_SLES15` set to `FALSE` on NCCS if not built on SLES15 + - ESMA_env v4.25.1 + - Baselibs 7.17.1 + - Fixes for NAG + - Use GCC 11.4 as Intel backing compiler at NCCS SLES15 ### Fixed diff --git a/components.yaml b/components.yaml index 044130166faa..12de3174b72c 100644 --- a/components.yaml +++ b/components.yaml @@ -5,13 +5,13 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.24.0 + tag: v4.25.1 develop: main ESMA_cmake: local: ./ESMA_cmake remote: ../ESMA_cmake.git - tag: v3.43.0 + tag: v3.44.0 develop: develop ecbuild: From 802bba2cbcc29977f455405d3ce3c52df9c06b77 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 1 Apr 2024 14:48:28 -0400 Subject: [PATCH 110/141] check if the number of nodes of o-server is consistent --- CHANGELOG.md | 1 + base/ServerManager.F90 | 23 ++++++++++++++++++++++- 2 files changed, 23 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index d06d983896a2..6c2999e45824 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Checked resource for o-server. It quits if the numer requested is inconsistent with being used - Allow fields with ungridded dimension and bundles to be created in ExtDataDriver.x - Allow arithmetic operations to be performed on fields from bundles in History - Adapted subroutine RegridVector from GriddedIO.F90 to MAPL_EpochSwathMod.F90 (changing class name for this) diff --git a/base/ServerManager.F90 b/base/ServerManager.F90 index fc666df00779..ddbd64a8d142 100644 --- a/base/ServerManager.F90 +++ b/base/ServerManager.F90 @@ -22,6 +22,7 @@ module MAPL_ServerManager procedure :: initialize procedure :: finalize procedure :: get_splitcomm + procedure :: check_resource end type contains @@ -217,6 +218,7 @@ subroutine initialize(this, comm, unusable, application_size, nodes_input_server do i = 1, n_oserver_group if ( trim(s_name) =='o_server'//trim(i_to_string(i)) ) then + if (oserver_type_ == 'multicomm' ) then allocate(this%o_server, source = MultiCommServer(this%split_comm%get_subcommunicator(), s_name, npes_out_backend)) @@ -227,11 +229,12 @@ subroutine initialize(this, comm, unusable, application_size, nodes_input_server npes_out_backend, './pfio_writer.x')) else if (oserver_type_ == 'multigroup' ) then - + allocate(this%o_server, source = MultiGroupServer(this%split_comm%get_subcommunicator(), s_name, npes_out_backend, & with_profiler=with_profiler, rc=status), stat=stat_alloc) _VERIFY(status) _VERIFY(stat_alloc) + call this%check_resource(nodes_out(i), _RC) else allocate(this%o_server, source = MpiServer(this%split_comm%get_subcommunicator(), s_name, with_profiler=with_profiler, rc=status), stat=stat_alloc) @@ -299,4 +302,22 @@ subroutine finalize(this,rc) _RETURN(_SUCCESS) end subroutine finalize + subroutine check_resource(this,nnode_out,rc) + class(ServerManager), intent(inout) :: this + integer, intent(in) :: nnode_out + integer, optional, intent(out) :: rc + integer :: status, rank + integer :: size, k + integer, allocatable :: node_sizes(:) + + call MPI_Comm_Rank(this%split_comm%get_subcommunicator(),rank,status) + if (rank == 0 .and. nnode_out /=0 ) then + if( this%o_server%node_num /= nnode_out) then + write(*,'(A, I0, A, I0, A)') "The requested ", nnode_out, " nodes for output server is different from available ", k , " nodes" + _FAIL("Inconsistent output server number") + endif + endif + _RETURN(_SUCCESS) + end subroutine + end module MAPL_ServerManager From 957978ee33721a972dd5bf1cc938d1e7b5bddb70 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 1 Apr 2024 13:31:43 -0600 Subject: [PATCH 111/141] replaced #if defined lev_b_lev by adding module variable level_by_level (Boolean) --- .../History/Sampler/MAPL_TrajectoryMod.F90 | 8 +++++ .../Sampler/MAPL_TrajectoryMod_smod.F90 | 29 +++++++++---------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 index 8ae2e3da209f..18f78e4e2d55 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod.F90 @@ -70,6 +70,14 @@ module HistoryTrajectoryMod integer :: obsfile_Ts_index ! for epoch integer :: obsfile_Te_index logical :: active ! case: when no obs. exist + logical :: level_by_level = .true. + ! note + ! for MPI_GATHERV of 3D data in procedure :: append_file + ! we have choice LEVEL_BY_LEVEL or ALL_AT_ONCE (timing in sec below for extdata) + ! c1440_L137_M1260 57.276 69.870 + ! c5760_L137_M8820 98.494 93.140 + ! M=cores + ! hence start using ALL_AT_ONCE from c5760+ contains procedure :: initialize => initialize_ procedure :: create_variable => create_metadata_variable diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index ff9d50691a11..d29e820a37e2 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -1046,7 +1046,6 @@ allocate ( p_dst_rt(lm, 1) ) end if -#define lev_b_lev 1 iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1120,21 +1119,21 @@ p_src= reshape(p_acc_3d,shape(p_src), order=[2,1]) call ESMF_FieldRegrid(src_field,dst_field,RH,_RC) -#if defined(lev_b_lev) - ! p_dst (lm, nx) - allocate ( p_dst_t, source = reshape ( p_dst, [size(p_dst,2),size(p_dst,1)], order=[2,1] ) ) - do k = 1, lm - call MPI_gatherv ( p_dst_t(1,k), nsend, MPI_REAL, & - p_acc_rt_3d(1,k), recvcount, displs, MPI_REAL,& + if (this%level_by_level) then + ! p_dst (lm, nx) + allocate ( p_dst_t, source = reshape ( p_dst, [size(p_dst,2),size(p_dst,1)], order=[2,1] ) ) + do k = 1, lm + call MPI_gatherv ( p_dst_t(1,k), nsend, MPI_REAL, & + p_acc_rt_3d(1,k), recvcount, displs, MPI_REAL,& + iroot, mpic, ierr ) + end do + deallocate (p_dst_t) + else + call MPI_gatherv ( p_dst, nsend_v, MPI_REAL, & + p_dst_rt, recvcount_v, displs_v, MPI_REAL,& iroot, mpic, ierr ) - end do - deallocate (p_dst_t) -#else - call MPI_gatherv ( p_dst, nsend_v, MPI_REAL, & - p_dst_rt, recvcount_v, displs_v, MPI_REAL,& - iroot, mpic, ierr ) - p_acc_rt_3d = reshape ( p_dst_rt, shape(p_acc_rt_3d), order=[2,1] ) -#endif + p_acc_rt_3d = reshape ( p_dst_rt, shape(p_acc_rt_3d), order=[2,1] ) + end if call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) From 5926d086d777a0f3c886d14adea332013bcb43a1 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 2 Apr 2024 11:38:52 -0600 Subject: [PATCH 112/141] use flogger --- .../Sampler/MAPL_TrajectoryMod_smod.F90 | 25 +++++++------------ 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index d29e820a37e2..902c9e1520f1 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -855,8 +855,7 @@ M = petCount recvcount = int(ip+1, INT64) * int(N, INT64) / int(M, INT64) - & int(ip , INT64) * int(N, INT64) / int(M, INT64) - -!! write(6,'(2x,a,2x,2i10)') 'ip, recvcount', ip, recvcount + call lgr%debug('%a %i12 %i12', 'ip, recvcount', ip, recvcount) allocate ( sendcount (petCount) ) allocate ( displs (petCount) ) @@ -923,10 +922,12 @@ module procedure append_file + use pflogger, only: Logger, logging type(GriddedIOitemVectorIterator) :: iter type(GriddedIOitem), pointer :: item type(ESMF_RouteHandle) :: RH - + type(Logger), pointer :: lgr + type(ESMF_Field) :: src_field, dst_field type(ESMF_Field) :: acc_field type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt @@ -963,7 +964,8 @@ rc=0 return endif - + lgr => logging%get_logger('HISTORY.sampler') + is=1 do k = 1, this%nobs_type !-- limit nx < 2**32 (integer*4) @@ -1045,7 +1047,7 @@ allocate ( p_acc_rt_3d(1,lm) ) allocate ( p_dst_rt(lm, 1) ) end if - + iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() @@ -1092,9 +1094,8 @@ nx = this%obs(k)%nobs_epoch if (nx>0) then do ig = 1, this%obs(k)%ngeoval - !!write(6,'(2x,a,2x,a)') 't this%obs(k)%geoval_xname(ig)', trim(this%obs(k)%geoval_xname(ig)) if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - !!write(6, '(2x,a,2x,a)') 'append:2d inner put_var item%xname', trim(item%xname) + call lgr%debug('%a %a', 'append:2d inner put_var item%xname', trim(item%xname)) call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p2d(1:nx), & start=[is],count=[nx]) end if @@ -1106,7 +1107,6 @@ enddo end if else if (rank==2) then - if (mapl_am_i_root()) write(6,*) 'in append rank=2, bg gatherv' call ESMF_FieldGet( acc_field, localDE=0, farrayPtr=p_acc_3d, _RC) dst_field=ESMF_FieldCreate(this%LS_chunk,typekind=ESMF_TYPEKIND_R4, & @@ -1138,7 +1138,6 @@ call ESMF_FieldDestroy(dst_field,noGarbage=.true.,_RC) call ESMF_FieldDestroy(src_field,noGarbage=.true.,_RC) - if (mapl_am_i_root()) write(6,*) 'in append rank=2, af gatherv' if (mapl_am_i_root()) then ! @@ -1164,18 +1163,13 @@ if (nx>0) then do ig = 1, this%obs(k)%ngeoval if (trim(item%xname) == trim(this%obs(k)%geoval_xname(ig))) then - !!write(6, '(2x,a,2x,a)') 'append:3d inner put_var item%xname', trim(item%xname) + call lgr%debug('%a %a', 'append:3d inner put_var item%xname', trim(item%xname)) call this%obs(k)%file_handle%put_var(trim(item%xname), this%obs(k)%p3d(:,:), & start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) end if end do endif enddo - !!write(6,'(10f8.2)') p_acc_rt_3d(:,:) - !!write(6,*) 'here in append_file: put_var 3d' - !!call this%obs(k)%file_handle%put_var(trim(item%xname),p_acc_rt_3d(:,:),& - !! start=[is,1],count=[nx,size(p_acc_rt_3d,2)]) - !! do k=1, this%nobs_type deallocate (this%obs(k)%p3d, _STAT) enddo @@ -1191,7 +1185,6 @@ call ESMF_FieldDestroy(acc_field_3d_chunk, noGarbage=.true., _RC) call ESMF_FieldRedistRelease(RH, noGarbage=.true., _RC) - _RETURN(_SUCCESS) end procedure append_file From ebb35d30ff490e16e1e8124b90061a7422df56cf Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 3 Apr 2024 07:35:43 -0400 Subject: [PATCH 113/141] Add missing INT64 use --- gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 902c9e1520f1..12c2c5060e69 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -23,6 +23,7 @@ use MPI, only : MPI_INTEGER, MPI_REAL, MPI_REAL8 use, intrinsic :: iso_fortran_env, only: REAL32 use, intrinsic :: iso_fortran_env, only: REAL64 + use, intrinsic :: iso_fortran_env, only: INT64 implicit none contains @@ -927,7 +928,7 @@ type(GriddedIOitem), pointer :: item type(ESMF_RouteHandle) :: RH type(Logger), pointer :: lgr - + type(ESMF_Field) :: src_field, dst_field type(ESMF_Field) :: acc_field type(ESMF_Field) :: acc_field_2d_rt, acc_field_3d_rt @@ -965,7 +966,7 @@ return endif lgr => logging%get_logger('HISTORY.sampler') - + is=1 do k = 1, this%nobs_type !-- limit nx < 2**32 (integer*4) @@ -1047,7 +1048,7 @@ allocate ( p_acc_rt_3d(1,lm) ) allocate ( p_dst_rt(lm, 1) ) end if - + iter = this%items%begin() do while (iter /= this%items%end()) item => iter%get() From 69074932f69209ab7cc5a9e46c48a1c6d488d268 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 3 Apr 2024 14:43:17 -0400 Subject: [PATCH 114/141] Update to Open MPI 4 --- components.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components.yaml b/components.yaml index b7e0fe647ca8..38ca0c946dc7 100644 --- a/components.yaml +++ b/components.yaml @@ -5,7 +5,7 @@ MAPL: ESMA_env: local: ./ESMA_env remote: ../ESMA_env.git - tag: v4.28.0 + tag: v4.28.1 develop: main ESMA_cmake: From 91d3dbc2df8397c429119311c68ae1972e5ddc48 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 3 Apr 2024 14:47:32 -0400 Subject: [PATCH 115/141] update CI to 7.23 --- .circleci/config.yml | 2 +- .github/workflows/workflow.yml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 936adf290499..112c3f9d7e04 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -16,7 +16,7 @@ parameters: # Anchors to prevent forgetting to update a version os_version: &os_version ubuntu20 -baselibs_version: &baselibs_version v7.17.0 +baselibs_version: &baselibs_version v7.23.0 bcs_version: &bcs_version v11.3.0 tag_build_arg_name: &tag_build_arg_name maplversion diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 4a360a7d2b51..3395269cf48b 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -17,7 +17,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.17.0-openmpi_5.0.0-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.23.0-openmpi_5.0.0-gcc_12.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests @@ -77,7 +77,7 @@ jobs: name: Build and Test MAPL Intel runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env:v7.17.0-intelmpi_2021.6.0-intel_2022.1.0 + image: gmao/ubuntu20-geos-env:v7.23.0-intelmpi_2021.6.0-intel_2022.1.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests From e235527e4592d1bbaf4d434acba91a81909c36ff Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 4 Apr 2024 13:14:53 -0400 Subject: [PATCH 116/141] more clear message --- base/ServerManager.F90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/base/ServerManager.F90 b/base/ServerManager.F90 index ddbd64a8d142..2ccdd4fc9430 100644 --- a/base/ServerManager.F90 +++ b/base/ServerManager.F90 @@ -310,12 +310,14 @@ subroutine check_resource(this,nnode_out,rc) integer :: size, k integer, allocatable :: node_sizes(:) + if (nnode_out == 0) then + _RETURN(_SUCCESS) + endif + call MPI_Comm_Rank(this%split_comm%get_subcommunicator(),rank,status) - if (rank == 0 .and. nnode_out /=0 ) then - if( this%o_server%node_num /= nnode_out) then - write(*,'(A, I0, A, I0, A)') "The requested ", nnode_out, " nodes for output server is different from available ", k , " nodes" - _FAIL("Inconsistent output server number") - endif + if (this%o_server%node_num /= nnode_out) then + _FAIL("Inconsistent output server number. " // "The requested "//i_to_string(nnode_out) & + //" nodes for output server is different from available "//i_to_string(k)// " nodes") endif _RETURN(_SUCCESS) end subroutine From 3fdfcb06442e4fb23e8a070ff12f3fdf52e59e5e Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 4 Apr 2024 14:32:19 -0400 Subject: [PATCH 117/141] simpler change --- base/ServerManager.F90 | 26 ++++---------------------- 1 file changed, 4 insertions(+), 22 deletions(-) diff --git a/base/ServerManager.F90 b/base/ServerManager.F90 index 2ccdd4fc9430..8beb4abec061 100644 --- a/base/ServerManager.F90 +++ b/base/ServerManager.F90 @@ -22,7 +22,6 @@ module MAPL_ServerManager procedure :: initialize procedure :: finalize procedure :: get_splitcomm - procedure :: check_resource end type contains @@ -234,7 +233,10 @@ subroutine initialize(this, comm, unusable, application_size, nodes_input_server with_profiler=with_profiler, rc=status), stat=stat_alloc) _VERIFY(status) _VERIFY(stat_alloc) - call this%check_resource(nodes_out(i), _RC) + if (nodes_out(i) > 0 .and. this%o_server%node_num /= nodes_out(i)) then + _FAIL("Inconsistent output server number. " // "The requested "//i_to_string(nodes_out(i)) & + //" nodes for output server is different from available "//i_to_string(this%o_server%node_num)// " nodes") + endif else allocate(this%o_server, source = MpiServer(this%split_comm%get_subcommunicator(), s_name, with_profiler=with_profiler, rc=status), stat=stat_alloc) @@ -302,24 +304,4 @@ subroutine finalize(this,rc) _RETURN(_SUCCESS) end subroutine finalize - subroutine check_resource(this,nnode_out,rc) - class(ServerManager), intent(inout) :: this - integer, intent(in) :: nnode_out - integer, optional, intent(out) :: rc - integer :: status, rank - integer :: size, k - integer, allocatable :: node_sizes(:) - - if (nnode_out == 0) then - _RETURN(_SUCCESS) - endif - - call MPI_Comm_Rank(this%split_comm%get_subcommunicator(),rank,status) - if (this%o_server%node_num /= nnode_out) then - _FAIL("Inconsistent output server number. " // "The requested "//i_to_string(nnode_out) & - //" nodes for output server is different from available "//i_to_string(k)// " nodes") - endif - _RETURN(_SUCCESS) - end subroutine - end module MAPL_ServerManager From 4f86f307aca378adeefa77152708a886692d8c78 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 10 Apr 2024 10:04:14 -0400 Subject: [PATCH 118/141] Clean up CI --- .circleci/config.yml | 71 ++++------------------------------ .github/workflows/workflow.yml | 14 +------ 2 files changed, 9 insertions(+), 76 deletions(-) diff --git a/.circleci/config.yml b/.circleci/config.yml index 112c3f9d7e04..b80539e281f7 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -26,14 +26,14 @@ orbs: workflows: build-and-test-MAPL: jobs: - # Builds MAPL in a "default" way - Intel + # Builds MAPL in a "default" way - ci/build: name: build-and-test-MAPL-on-<< matrix.compiler >>-using-<< matrix.cmake_generator >> context: - docker-hub-creds matrix: parameters: - compiler: [ifort] + compiler: [gfortran,ifort] cmake_generator: ['Unix Makefiles','Ninja'] baselibs_version: *baselibs_version repo: MAPL @@ -42,32 +42,6 @@ workflows: ctest_options: "-L 'ESSENTIAL' --output-on-failure" persist_workspace: true # Needed for MAPL tutorials - # Builds MAPL in a "default" way - GNU - # - # NOTE: Currently Open MPI fails on the bundleio with: - # - # The OSC pt2pt component does not support MPI_THREAD_MULTIPLE in this release. - # Workarounds are to run on a single node, or to use a system with an RDMA - # capable network such as Infiniband. - # - # For now, we run GNU/Open MPI without the bundleio tests. Some indications that - # Open MPI 5 will not have this limitation - - - ci/build: - name: build-and-test-MAPL-on-<< matrix.compiler >>-using-<< matrix.cmake_generator >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [gfortran] - cmake_generator: ['Unix Makefiles','Ninja'] - baselibs_version: *baselibs_version - repo: MAPL - mepodevelop: false - run_unit_tests: true - ctest_options: "-E bundleio -L 'ESSENTIAL' --output-on-failure" - persist_workspace: true # Needed for MAPL tutorials - # Builds MAPL like UFS does (no FLAP and pFlogger, static) - ci/build: name: build-UFS-MAPL-on-<< matrix.compiler >> @@ -92,8 +66,7 @@ workflows: - docker-hub-creds matrix: parameters: - #compiler: [gfortran, ifort] - compiler: [ifort] + compiler: [gfortran, ifort] tutorial_name: - hello_world - parent_no_children @@ -108,29 +81,14 @@ workflows: build-and-run-GEOSgcm: jobs: - # Build GEOSgcm -- ifort - - ci/build: - name: build-GEOSgcm-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - baselibs_version: *baselibs_version - repo: GEOSgcm - checkout_fixture: true - mepodevelop: true - checkout_mapl_branch: true - persist_workspace: true # Needs to be true to run fv3/gcm experiment, costs extra, retained for one day - - # Build GEOSgcm -- GCC + # Build GEOSgcm - ci/build: name: build-GEOSgcm-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: - compiler: [gfortran] + compiler: [gfortran, ifort] baselibs_version: *baselibs_version repo: GEOSgcm checkout_fixture: true @@ -170,29 +128,14 @@ workflows: build-GEOSldas: jobs: - # Build GEOSldas on ifort - - ci/build: - name: build-GEOSldas-on-<< matrix.compiler >> - context: - - docker-hub-creds - matrix: - parameters: - compiler: [ifort] - baselibs_version: *baselibs_version - repo: GEOSldas - mepodevelop: false - checkout_fixture: true - fixture_branch: develop - checkout_mapl_branch: true - - # Build GEOSldas on gfortran + # Build GEOSldas - ci/build: name: build-GEOSldas-on-<< matrix.compiler >> context: - docker-hub-creds matrix: parameters: - compiler: [gfortran] + compiler: [gfortran,ifort] baselibs_version: *baselibs_version repo: GEOSldas mepodevelop: false diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 3395269cf48b..e8634bab8aa8 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -63,16 +63,7 @@ jobs: run: | cd build make -j4 build-tests - # skip performance tests - # NOTE: Currently Open MPI fails on the bundleio with: - # - # The OSC pt2pt component does not support MPI_THREAD_MULTIPLE in this release. - # Workarounds are to run on a single node, or to use a system with an RDMA - # capable network such as Infiniband. - # - # For now, we run GNU/Open MPI without the bundleio tests. Some indications that - # Open MPI 5 will not have this limitation - ctest -E bundleio -LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure + ctest -L 'ESSENTIAL' --output-on-failure build_test_mapl_intel: name: Build and Test MAPL Intel runs-on: ubuntu-latest @@ -119,5 +110,4 @@ jobs: run: | cd build make -j4 build-tests - # skip performance tests - ctest -LE 'PERFORMANCE|EXTDATA1G_BIG_TESTS|EXTDATA2G_BIG_TESTS' --output-on-failure + ctest -L 'ESSENTIAL' --output-on-failure From cb3e0fd8ff1a3a2d047fec63e90331410ab77ea5 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Thu, 11 Apr 2024 11:00:55 -0400 Subject: [PATCH 119/141] Update ServerManager.F90 --- base/ServerManager.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/base/ServerManager.F90 b/base/ServerManager.F90 index 8beb4abec061..93f160d475bb 100644 --- a/base/ServerManager.F90 +++ b/base/ServerManager.F90 @@ -234,8 +234,7 @@ subroutine initialize(this, comm, unusable, application_size, nodes_input_server _VERIFY(status) _VERIFY(stat_alloc) if (nodes_out(i) > 0 .and. this%o_server%node_num /= nodes_out(i)) then - _FAIL("Inconsistent output server number. " // "The requested "//i_to_string(nodes_out(i)) & - //" nodes for output server is different from available "//i_to_string(this%o_server%node_num)// " nodes") + _FAIL("Inconsistent output server number. " // "The requested "//i_to_string(nodes_out(i)) //" nodes for output server is different from available "//i_to_string(this%o_server%node_num)// " nodes") endif else From a083ff7ca4f6d3c73e0092c6d6878645db72529f Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 11 Apr 2024 15:58:29 -0400 Subject: [PATCH 120/141] release pfio memory as earlyr as possible --- CHANGELOG.md | 1 + base/Base/Base_Base_implementation.F90 | 1 + pfio/ForwardDataAndMessage.F90 | 15 +++++++++++++++ pfio/MultiGroupServer.F90 | 16 +++++++++++++--- 4 files changed, 30 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ffdebac228d1..aadec4981863 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Release the pfio memory as early as possible - Replace local HorzIJIndex sear with the GlobalHorzIJindex search - Change grd_is_ok function to avoid collective call - Allow fields with ungridded dimension and bundles to be created in ExtDataDriver.x diff --git a/base/Base/Base_Base_implementation.F90 b/base/Base/Base_Base_implementation.F90 index 30b018eeba43..20b27e36deea 100644 --- a/base/Base/Base_Base_implementation.F90 +++ b/base/Base/Base_Base_implementation.F90 @@ -2900,6 +2900,7 @@ function grid_is_ok(grid) result(OK) print*, "Error: It could be " print*, " 1)Grid is NOT gnomonic_ed;" print*, " 2)lats lons from MAPL_GridGetCorners are NOT accurate (single precision from ESMF)" + print*, " 3)This is a stretched grid which is not yet supported" OK = .false. return endif diff --git a/pfio/ForwardDataAndMessage.F90 b/pfio/ForwardDataAndMessage.F90 index ec6f5e7fb1dd..527ce87cfd06 100644 --- a/pfio/ForwardDataAndMessage.F90 +++ b/pfio/ForwardDataAndMessage.F90 @@ -26,6 +26,7 @@ module pFIO_ForwardDataAndMessageMod procedure :: add_data_message procedure :: serialize procedure :: deserialize + procedure :: destroy end type ForwardDataAndMessage interface ForwardDataAndMessage @@ -104,5 +105,19 @@ subroutine add_data_message(this, msg, i_ptr, rc) _RETURN(_SUCCESS) end subroutine + subroutine destroy(this, rc) + class (ForwardDataAndMessage), intent(inout) :: this + integer, optional, intent(out) :: rc + type (MessageVectorIterator) :: iter + + if (allocated(this%idata)) deallocate(this%idata) + iter = this%msg_vec%begin() + do while (iter /= this%msg_vec%end()) + call this%msg_vec%erase(iter) + iter = this%msg_vec%begin() + enddo + + end subroutine + end module pFIO_ForwardDataAndMessageMod diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index 71278ddd922b..4d9d26297653 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -312,7 +312,7 @@ subroutine receive_output_data(this, rc) class (MultiGroupServer),target, intent(inout) :: this integer, optional, intent(out) :: rc - integer :: i, client_num + integer :: i, client_num, status class (ServerThread),pointer :: thread_ptr type (MessageVectorIterator) :: iter @@ -419,13 +419,15 @@ subroutine receive_output_data(this, rc) call Mpi_Bcast( back_local_rank, 1, MPI_INTEGER, 0, this%front_comm, ierror) - if (allocated(this%buffers(back_local_rank+1)%buffer)) call MPI_Wait(this%buffers(back_local_rank+1)%request, MPI_STAT, ierror) call f_d_ms(collection_counter)%serialize(this%buffers(back_local_rank+1)%buffer) + call f_d_ms(collection_counter)%destroy(_RC) msg_size= size(this%buffers(back_local_rank+1)%buffer) call Mpi_send(msg_size,1, MPI_INTEGER, this%back_ranks(back_local_rank+1), & this%back_ranks(back_local_rank+1), this%server_comm, ierror) call Mpi_Isend(this%buffers(back_local_rank+1)%buffer, msg_size, MPI_INTEGER, this%back_ranks(back_local_rank+1), & this%back_ranks(back_local_rank+1), this%server_comm, this%buffers(back_local_rank+1)%request,ierror) + call MPI_Wait(this%buffers(back_local_rank+1)%request, MPI_STAT, ierror) + deallocate(this%buffers(back_local_rank+1)%buffer) if (associated(ioserver_profiler)) call ioserver_profiler%stop("collection_"//i_to_string(collection_id)) enddo if (associated(ioserver_profiler)) call ioserver_profiler%stop("forward_data") @@ -841,9 +843,18 @@ subroutine start_back_writers(rc) call file_timer%stop() end select call msg_iter%next() + call attr_ptr%destroy(_RC) + call vars_map%erase(var_iter) enddo + msg_iter = msg_map%begin() + do while (msg_iter /= msg_map%end()) + call msg_map%erase(msg_iter) + msg_iter = msg_map%begin() + enddo + call thread_ptr%clear_hist_collections() call thread_ptr%hist_collections%clear() + deallocate (buffer_fmd) time = file_timer%get_total() file_size = file_size*4./1024./1024. ! 4-byte integer, unit is converted to MB @@ -852,7 +863,6 @@ subroutine start_back_writers(rc) call lgr%info(" Writing time: %f9.3 s, speed: %f9.3 MB/s, size: %f9.3 MB, at server node: %i0~:%i0~, file: %a", time, speed, file_size, this%node_rank, this%innode_rank, filename) call file_timer%reset() - deallocate (buffer_fmd) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! telling captain it is idle by sending its own rank From 0d47f46f4938b1426a3da48dfa4e7b33c2b963f2 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 11 Apr 2024 18:33:57 -0400 Subject: [PATCH 121/141] fix return --- pfio/ForwardDataAndMessage.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pfio/ForwardDataAndMessage.F90 b/pfio/ForwardDataAndMessage.F90 index 527ce87cfd06..d9c42ba162e7 100644 --- a/pfio/ForwardDataAndMessage.F90 +++ b/pfio/ForwardDataAndMessage.F90 @@ -116,7 +116,7 @@ subroutine destroy(this, rc) call this%msg_vec%erase(iter) iter = this%msg_vec%begin() enddo - + _RETURN(_SUCCESS) end subroutine end module pFIO_ForwardDataAndMessageMod From 15b77c0d9532c5faca6f72beab437d7b6ac4eb62 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 15 Apr 2024 08:56:44 -0600 Subject: [PATCH 122/141] update glob function --- CHANGELOG.md | 1 + base/CMakeLists.txt | 2 +- base/MAPL_ObsUtil.F90 | 69 +++++++++++++++++++++++++++++++++++++++++-- base/MAPL_ObsUtil.c | 31 +++++++++++++++++++ 4 files changed, 99 insertions(+), 4 deletions(-) create mode 100644 base/MAPL_ObsUtil.c diff --git a/CHANGELOG.md b/CHANGELOG.md index d050f8ad9124..ce8d4744abe6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Add glob function in sampler code, supporting wild character, e.g., filename template = amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4 - Checked resource for o-server. It quits if the numer requested is inconsistent with being used - Replace local HorzIJIndex sear with the GlobalHorzIJindex search - Change grd_is_ok function to avoid collective call diff --git a/base/CMakeLists.txt b/base/CMakeLists.txt index 02aa55f6af08..8f8945af4771 100644 --- a/base/CMakeLists.txt +++ b/base/CMakeLists.txt @@ -47,7 +47,7 @@ set (srcs ESMF_CFIOPtrVectorMod.F90 CFIOCollection.F90 MAPL_CFIO.F90 regex_module.F90 StringTemplate.F90 MAPL_SphericalGeometry.F90 - regex_F.c + regex_F.c MAPL_ObsUtil.c c_mapl_locstream_F.c getrss.c memuse.c Base/Base_Base.F90 Base/Base_Base_implementation.F90 TimeStringConversion.F90 diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 17e41d718d71..9a0adf868720 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -10,6 +10,7 @@ module MAPL_ObsUtilMod use pFIO_FileMetadataMod, only : FileMetadata use pFIO_NetCDF4_FileFormatterMod, only : NetCDF4_FileFormatter use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + use, intrinsic :: iso_c_binding implicit none integer, parameter :: mx_ngeoval = 60 ! GRS80 by Moritz @@ -59,6 +60,18 @@ module MAPL_ObsUtilMod module procedure sort_four_arrays_by_time end interface sort_multi_arrays_by_time + interface + function f_call_c_glob(search_name, filename, slen) & + & result(stat) bind(C, name="glob_C") + use, intrinsic :: iso_c_binding + implicit none + integer :: stat + character (kind=c_char), intent(in) :: search_name(*) + character (kind=c_char), intent(out) :: filename(*) + integer, intent(inout) :: slen + end function f_call_c_glob + end interface + contains subroutine get_obsfile_Tbracket_from_epoch(currTime, & @@ -546,12 +559,14 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter type(ESMF_TimeInterval) :: dT type(ESMF_Time) :: time integer :: i, j, u + logical :: allow_wild_char character(len=ESMF_MAXSTR) :: file_template_left character(len=ESMF_MAXSTR) :: file_template_right character(len=ESMF_MAXSTR) :: filename_left character(len=ESMF_MAXSTR) :: filename_full character(len=ESMF_MAXSTR) :: filename2 + character(len=ESMF_MAXSTR) :: filename3 character(len=ESMF_MAXSTR) :: cmd call ESMF_TimeIntervalGet(obsfile_interval, s_r8=dT0_s, rc=status) @@ -565,9 +580,34 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter ! parse time info ! - call fill_grads_template ( filename, file_template, & - experiment_id='', nymd=nymd, nhms=nhms, _RC ) - inquire(file= trim(filename), EXIST = exist) + ! + allow_wild_char=.true. + ! + j= index(file_template, '*') + if (j>0) then + ! wild char exist + !!print*, 'pos of * in template =', j + file_template_left = file_template(1:j-1) + call fill_grads_template ( filename_left, file_template_left, & + experiment_id='', nymd=nymd, nhms=nhms, _RC ) + filename2= trim(filename_left)//trim(file_template(j:)) + call fglob(filename2, filename3, rc=status) + if (status==0) then + ! the *-file is found + exist=.true. + filename=trim(filename3) + else + ! the *-file is not found + exist=.false. + filename=filename2 + end if + ! + else + ! exact file name + call fill_grads_template ( filename, file_template, & + experiment_id='', nymd=nymd, nhms=nhms, _RC ) + inquire(file= trim(filename), EXIST = exist) + end if _RETURN(_SUCCESS) @@ -913,4 +953,27 @@ subroutine test_conversion end subroutine test_conversion + + subroutine fglob(search_name, filename, rc) ! give the last name + character(len=*), intent(in) :: search_name + character(len=*), intent(INOUT) :: filename + integer, optional, intent(out) :: rc + + character(kind=C_CHAR, len=:), allocatable :: c_search_name + character(kind=C_CHAR, len=512) :: c_filename + integer n, status, slen + + n=len(trim(search_name)) + allocate(character(kind=C_CHAR,len=n+1) :: c_search_name) + c_search_name(1:n)=search_name(1:n) + c_search_name(n+1:n+1)=c_null_char + + rc = f_call_c_glob(c_search_name, c_filename, slen) + filename="" + if (slen>0) filename(1:slen)=c_filename(1:slen) + + deallocate(c_search_name) + return + end subroutine fglob + end module MAPL_ObsUtilMod diff --git a/base/MAPL_ObsUtil.c b/base/MAPL_ObsUtil.c new file mode 100644 index 000000000000..aadf17ddef93 --- /dev/null +++ b/base/MAPL_ObsUtil.c @@ -0,0 +1,31 @@ +#include +#include +#include + +int glob_C (char*, char*, int*); + +int glob_C (char *pattern, char *filename, int* stringlen) +{ + glob_t globlist; + int error = 1; + int failure = -1; + char *s; + + int j = glob( pattern, GLOB_ERR, NULL, &globlist ); + if ( j == GLOB_NOSPACE || j == GLOB_NOMATCH ) + return (failure); + if ( j == GLOB_ABORTED) + return (error); + + int i = 0; + for (; globlist.gl_pathv[i] ; ++i) + // printf("f = %s\n", globlist.gl_pathv[i]); + ; + s = globlist.gl_pathv[--i]; + for (i=0; *(s+i) != '\0'; i++) + *(filename+i) = *(s+i); + if (i>512) return error; + *stringlen = i; + + return 0; +} From d3337cf8081742287e44713f0fa4fbd637705ae3 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Mon, 15 Apr 2024 11:00:39 -0400 Subject: [PATCH 123/141] wait and destroy the memory when it is necessary --- pfio/MultiGroupServer.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index 4d9d26297653..befbc546f0c7 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -418,7 +418,7 @@ subroutine receive_output_data(this, rc) endif call Mpi_Bcast( back_local_rank, 1, MPI_INTEGER, 0, this%front_comm, ierror) - + if (allocated(this%buffers(back_local_rank+1)%buffer)) call MPI_Wait(this%buffers(back_local_rank+1)%request, MPI_STAT, ierror) call f_d_ms(collection_counter)%serialize(this%buffers(back_local_rank+1)%buffer) call f_d_ms(collection_counter)%destroy(_RC) msg_size= size(this%buffers(back_local_rank+1)%buffer) @@ -426,8 +426,6 @@ subroutine receive_output_data(this, rc) this%back_ranks(back_local_rank+1), this%server_comm, ierror) call Mpi_Isend(this%buffers(back_local_rank+1)%buffer, msg_size, MPI_INTEGER, this%back_ranks(back_local_rank+1), & this%back_ranks(back_local_rank+1), this%server_comm, this%buffers(back_local_rank+1)%request,ierror) - call MPI_Wait(this%buffers(back_local_rank+1)%request, MPI_STAT, ierror) - deallocate(this%buffers(back_local_rank+1)%buffer) if (associated(ioserver_profiler)) call ioserver_profiler%stop("collection_"//i_to_string(collection_id)) enddo if (associated(ioserver_profiler)) call ioserver_profiler%stop("forward_data") From 9ee744fee97b2a0ec7d7328920156b7ede5102a9 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Mon, 15 Apr 2024 16:02:05 -0600 Subject: [PATCH 124/141] update, e.g., let fill_grads_template to pass file-*.nc --- base/MAPL_ObsUtil.F90 | 47 ++++++++++++++----------------------------- base/MAPL_ObsUtil.c | 9 +++++---- 2 files changed, 20 insertions(+), 36 deletions(-) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index 9a0adf868720..a075d0ebd4a5 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -560,14 +560,8 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter type(ESMF_Time) :: time integer :: i, j, u logical :: allow_wild_char - - character(len=ESMF_MAXSTR) :: file_template_left - character(len=ESMF_MAXSTR) :: file_template_right - character(len=ESMF_MAXSTR) :: filename_left - character(len=ESMF_MAXSTR) :: filename_full character(len=ESMF_MAXSTR) :: filename2 - character(len=ESMF_MAXSTR) :: filename3 - character(len=ESMF_MAXSTR) :: cmd + call ESMF_TimeIntervalGet(obsfile_interval, s_r8=dT0_s, rc=status) s = dT0_s * f_index @@ -582,31 +576,24 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter ! ! allow_wild_char=.true. - ! j= index(file_template, '*') - if (j>0) then - ! wild char exist - !!print*, 'pos of * in template =', j - file_template_left = file_template(1:j-1) - call fill_grads_template ( filename_left, file_template_left, & - experiment_id='', nymd=nymd, nhms=nhms, _RC ) - filename2= trim(filename_left)//trim(file_template(j:)) - call fglob(filename2, filename3, rc=status) + if (.NOT. allow_wild_char .AND. j>0) then + _FAIL("* is not allowed in template") + end if + call fill_grads_template ( filename, file_template, & + experiment_id='', nymd=nymd, nhms=nhms, _RC ) + if (j==0) then + ! exact file name + inquire(file= trim(filename), EXIST = exist) + else + ! now filename is: file*.nc + call fglob(filename, filename2, rc=status) if (status==0) then - ! the *-file is found exist=.true. - filename=trim(filename3) + filename=trim(filename2) else - ! the *-file is not found exist=.false. - filename=filename2 end if - ! - else - ! exact file name - call fill_grads_template ( filename, file_template, & - experiment_id='', nymd=nymd, nhms=nhms, _RC ) - inquire(file= trim(filename), EXIST = exist) end if _RETURN(_SUCCESS) @@ -961,13 +948,9 @@ subroutine fglob(search_name, filename, rc) ! give the last name character(kind=C_CHAR, len=:), allocatable :: c_search_name character(kind=C_CHAR, len=512) :: c_filename - integer n, status, slen - - n=len(trim(search_name)) - allocate(character(kind=C_CHAR,len=n+1) :: c_search_name) - c_search_name(1:n)=search_name(1:n) - c_search_name(n+1:n+1)=c_null_char + integer slen + c_search_name = trim(search_name)//C_NULL_CHAR rc = f_call_c_glob(c_search_name, c_filename, slen) filename="" if (slen>0) filename(1:slen)=c_filename(1:slen) diff --git a/base/MAPL_ObsUtil.c b/base/MAPL_ObsUtil.c index aadf17ddef93..9323504591ab 100644 --- a/base/MAPL_ObsUtil.c +++ b/base/MAPL_ObsUtil.c @@ -4,28 +4,29 @@ int glob_C (char*, char*, int*); -int glob_C (char *pattern, char *filename, int* stringlen) +int glob_C (char *pattern, char *filename, int *stringlen) { glob_t globlist; int error = 1; int failure = -1; char *s; + int MAXLEN = 512; // set path length limit int j = glob( pattern, GLOB_ERR, NULL, &globlist ); - if ( j == GLOB_NOSPACE || j == GLOB_NOMATCH ) + if ( j == GLOB_NOSPACE || j == GLOB_NOMATCH ) return (failure); if ( j == GLOB_ABORTED) return (error); int i = 0; - for (; globlist.gl_pathv[i] ; ++i) + for (; globlist.gl_pathv[i] ; i++) // printf("f = %s\n", globlist.gl_pathv[i]); ; s = globlist.gl_pathv[--i]; for (i=0; *(s+i) != '\0'; i++) *(filename+i) = *(s+i); - if (i>512) return error; *stringlen = i; + if ( i > MAXLEN ) return error; return 0; } From fcb9f39267409a92dea1794968d892e2eb7cdec4 Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Tue, 16 Apr 2024 09:04:30 -0600 Subject: [PATCH 125/141] Use succint statements to replace klunky ones --- base/MAPL_ObsUtil.F90 | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index a075d0ebd4a5..f11344f53efd 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -574,12 +574,9 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter ! parse time info ! - ! allow_wild_char=.true. j= index(file_template, '*') - if (.NOT. allow_wild_char .AND. j>0) then - _FAIL("* is not allowed in template") - end if + _ASSERT ( j==0 .OR. allow_wild_char, "* is not allowed in template") call fill_grads_template ( filename, file_template, & experiment_id='', nymd=nymd, nhms=nhms, _RC ) if (j==0) then @@ -588,12 +585,8 @@ function get_filename_from_template_use_index (obsfile_start_time, obsfile_inter else ! now filename is: file*.nc call fglob(filename, filename2, rc=status) - if (status==0) then - exist=.true. - filename=trim(filename2) - else - exist=.false. - end if + exist = (status==0) + if (exist) filename=trim(filename2) end if _RETURN(_SUCCESS) From b8d98f89563270cd06a775f72f32056cc25fa74f Mon Sep 17 00:00:00 2001 From: Tom Clune Date: Tue, 16 Apr 2024 11:21:27 -0400 Subject: [PATCH 126/141] Update base/MAPL_ObsUtil.F90 --- base/MAPL_ObsUtil.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/base/MAPL_ObsUtil.F90 b/base/MAPL_ObsUtil.F90 index f11344f53efd..b5da6efa79d2 100644 --- a/base/MAPL_ObsUtil.F90 +++ b/base/MAPL_ObsUtil.F90 @@ -948,7 +948,6 @@ subroutine fglob(search_name, filename, rc) ! give the last name filename="" if (slen>0) filename(1:slen)=c_filename(1:slen) - deallocate(c_search_name) return end subroutine fglob From 13694c0782dd788ad54bd8049081cf4e8cf54a67 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 17 Apr 2024 15:16:52 -0400 Subject: [PATCH 127/141] use int array to avoid cast --- pfio/CMakeLists.txt | 1 + pfio/IntArray.F90 | 101 ++++++++++++++++++++++++++++++++++++++ pfio/MultiGroupServer.F90 | 47 +++++++----------- 3 files changed, 121 insertions(+), 28 deletions(-) create mode 100644 pfio/IntArray.F90 diff --git a/pfio/CMakeLists.txt b/pfio/CMakeLists.txt index f85647b4a163..15390fb324e5 100644 --- a/pfio/CMakeLists.txt +++ b/pfio/CMakeLists.txt @@ -13,6 +13,7 @@ set (srcs pFIO_Constants.F90 UnlimitedEntity.F90 Attribute.F90 + IntArray.F90 Variable.F90 CoordinateVariable.F90 StringVariableMap.F90 diff --git a/pfio/IntArray.F90 b/pfio/IntArray.F90 new file mode 100644 index 000000000000..c308682bfd5b --- /dev/null +++ b/pfio/IntArray.F90 @@ -0,0 +1,101 @@ +!------------------------------------------------------------------------------ +! Global Modeling and Assimilation Office (GMAO) ! +! Goddard Earth Observing System (GEOS) ! +! MAPL Component ! +!------------------------------------------------------------------------------ +#include "MAPL_ErrLog.h" +#include "unused_dummy.H" + +!> +!### MODULE: `pFIO_IntArrayMod` +! +! Author: GMAO SI-Team +! +! The module `pFIO_IntArrayMod` is a simple integer 1d attribute to avoid ifort bug ( until 2024.0.0) +! +module pFIO_IntArrayMod + + use pFIO_ConstantsMod + use pFIO_UtilitiesMod + use MAPL_ExceptionHandling + use, intrinsic :: iso_fortran_env, only: INT32, INT64 + use, intrinsic :: iso_fortran_env, only: REAL32, REAL64 + + implicit none + private + + public :: IntArray + type :: IntArray + integer, allocatable :: values(:) + contains + procedure :: get_values + procedure :: destroy + end type IntArray + + interface IntArray + module procedure new_IntArray_1d !! vector constructor + module procedure new_IntArray_1d_size !! just size + end interface IntArray + +contains + + function new_IntArray_1d(values, rc) result(attr) + type (IntArray) :: attr + integer, intent(in) :: values(:) + integer, optional, intent(out) :: rc + + allocate(attr%values, source=values) + + _RETURN(_SUCCESS) + end function new_IntArray_1d + + function new_IntArray_1d_size(size, rc) result(attr) + type (IntArray) :: attr + integer(kind=INT64), intent(in) :: size + integer, optional, intent(out) :: rc + + allocate(attr%values(size)) + + _RETURN(_SUCCESS) + end function new_IntArray_1d_size + + subroutine destroy(this, rc) + class (IntArray), intent(inout) :: this + integer, optional, intent(out) :: rc + if(allocated(this%values)) deallocate(this%values) + _RETURN(_SUCCESS) + end subroutine destroy + + function get_values(this, rc) result(values) + class (IntArray), target, intent(in) :: this + integer, optional, intent(out) :: rc + integer, pointer :: values(:) + + if (allocated(this%values)) then + values => this%values + else + values => null() + end if + _RETURN(_SUCCESS) + end function get_values + +end module pFIO_IntArrayMod + + +! The following module defines an FTL map (associative array) with keys that are deferred +! length strings and values that are IntArrays. + +module pFIO_StringIntArrayMapMod + use pFIO_IntArrayMod + +#include "types/key_deferredLengthString.inc" +#define _value type (IntArray) +#define _value_equal_defined + +#define _map StringIntArrayMap +#define _iterator StringIntArrayMapIterator + +#define _alt +#include "templates/map.inc" + +end module pFIO_StringIntArrayMapMod diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index 71278ddd922b..a0c6d0dc4e72 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -35,9 +35,8 @@ module pFIO_MultiGroupServerMod use pFIO_HistoryCollectionVectorMod use pFIO_HistoryCollectionVectorUtilMod use pFIO_BaseServerMod - use pFIO_AttributeMod - use pFIO_StringAttributeMapMod - use pFIO_StringAttributeMapUtilMod + use pFIO_IntArrayMod + use pFIO_StringIntArrayMapMod use MAPL_SplitCommunicatorMod use MAPL_SimpleCommSplitterMod use pFIO_MpiSocketMod @@ -625,15 +624,15 @@ subroutine start_back_writers(rc) integer, pointer :: g_4d(:,:,:,:), l_4d(:,:,:,:), g_5d(:,:,:,:,:), l_5d(:,:,:,:,:) integer :: d_rank, request_id integer(kind=INT64) :: msize_word, s0, e0, s1, e1, s2, e2, s3, e3, s4, e4, s5, e5 - type (StringAttributeMap), target :: vars_map - type (StringAttributeMapIterator) :: var_iter + type (StringIntArrayMap), target :: vars_map + type (StringIntArrayMapIterator) :: var_iter type (IntegerMessageMap), target :: msg_map type (IntegerMessageMapIterator) :: msg_iter - class (*), pointer :: x_ptr(:) + integer, pointer :: x_ptr(:) integer , allocatable :: buffer_v(:) - type (Attribute), pointer :: attr_ptr - type (Attribute) :: attr_tmp + type (IntArray), pointer :: array_ptr + type (IntArray) :: array_tmp type (c_ptr) :: address type (ForwardDataAndMessage), target :: f_d_m type (FileMetaData) :: fmd @@ -644,7 +643,6 @@ subroutine start_back_writers(rc) real(kind=REAL64) :: file_size, speed class(Logger), pointer :: lgr - back_local_rank = this%rank thread_ptr => this%threads%at(1) file_timer = AdvancedMeter(MpiTimerGauge()) @@ -682,7 +680,7 @@ subroutine start_back_writers(rc) enddo ! nfront ! re-org data - vars_map = StringAttributeMap() + vars_map = StringIntArrayMap() msg_map = IntegerMessageMap() file_size = 0. @@ -699,23 +697,19 @@ subroutine start_back_writers(rc) msg => f_d_m%msg_vec%at(j) select type (q=>msg) type is (CollectiveStageDataMessage) + msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) var_iter = vars_map%find(i_to_string(q%request_id)) if (var_iter == vars_map%end()) then msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) - allocate(buffer_v(msize_word), source = -1) - attr_tmp = Attribute(buffer_v) - deallocate(buffer_v) - call vars_map%insert(i_to_string(q%request_id),attr_tmp) - call attr_tmp%destroy() + array_tmp = IntArray(msize_word) + call vars_map%insert(i_to_string(q%request_id),array_tmp) + call array_tmp%destroy() var_iter = vars_map%find(i_to_string(q%request_id)) call msg_map%insert(q%request_id, q) endif - attr_ptr => var_iter%value() - x_ptr => attr_ptr%get_values() - select type (ptr=>x_ptr) - type is (integer(INT32)) - address = c_loc(ptr(1)) - end select + array_ptr => var_iter%value() + x_ptr => array_ptr%get_values() + address = c_loc(x_ptr(1)) d_rank = size(q%global_count) ! first dimension increases q%global_count(1) = word_size(q%type_kind)*q%global_count(1) @@ -825,14 +819,10 @@ subroutine start_back_writers(rc) do while (msg_iter /= msg_map%end()) request_id = msg_iter%key() msg =>msg_iter%value() - var_iter = vars_map%find(i_to_string(request_id)) - attr_ptr =>var_iter%value() - x_ptr => attr_ptr%get_values() - select type (ptr=>x_ptr) - type is (integer(INT32)) - address = c_loc(ptr(1)) - end select + array_ptr =>var_iter%value() + x_ptr => array_ptr%get_values() + address = c_loc(x_ptr(1)) select type (q=>msg) class is (AbstractDataMessage) filename =q%file_name @@ -841,6 +831,7 @@ subroutine start_back_writers(rc) call file_timer%stop() end select call msg_iter%next() + call array_ptr%destroy() enddo call thread_ptr%clear_hist_collections() call thread_ptr%hist_collections%clear() From 34bf57f8a73c9f219a9a0ae516d506b415badf24 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 18 Apr 2024 11:43:17 -0400 Subject: [PATCH 128/141] change to pointer --- pfio/IntArray.F90 | 6 +++--- pfio/MultiGroupServer.F90 | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/pfio/IntArray.F90 b/pfio/IntArray.F90 index c308682bfd5b..8783578b1c53 100644 --- a/pfio/IntArray.F90 +++ b/pfio/IntArray.F90 @@ -26,7 +26,7 @@ module pFIO_IntArrayMod public :: IntArray type :: IntArray - integer, allocatable :: values(:) + integer, pointer :: values(:) contains procedure :: get_values procedure :: destroy @@ -62,7 +62,7 @@ end function new_IntArray_1d_size subroutine destroy(this, rc) class (IntArray), intent(inout) :: this integer, optional, intent(out) :: rc - if(allocated(this%values)) deallocate(this%values) + if(associated(this%values)) deallocate(this%values) _RETURN(_SUCCESS) end subroutine destroy @@ -71,7 +71,7 @@ function get_values(this, rc) result(values) integer, optional, intent(out) :: rc integer, pointer :: values(:) - if (allocated(this%values)) then + if (associated(this%values)) then values => this%values else values => null() diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index a0c6d0dc4e72..c2af92986202 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -703,7 +703,7 @@ subroutine start_back_writers(rc) msize_word = word_size(q%type_kind)*product(int(q%global_count, INT64)) array_tmp = IntArray(msize_word) call vars_map%insert(i_to_string(q%request_id),array_tmp) - call array_tmp%destroy() + !call array_tmp%destroy() var_iter = vars_map%find(i_to_string(q%request_id)) call msg_map%insert(q%request_id, q) endif From 2666e4603a060f02940dbd178af829816c8222a5 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 18 Apr 2024 11:21:27 -0600 Subject: [PATCH 129/141] Add Ford CI job --- .github/workflows/workflow.yml | 14 +++++++ CHANGELOG.md | 3 +- docs/Ford/ford-ci.md | 68 ++++++++++++++++++++++++++++++++++ 3 files changed, 84 insertions(+), 1 deletion(-) create mode 100644 docs/Ford/ford-ci.md diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index e8634bab8aa8..91260a1ec4f9 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -13,6 +13,20 @@ on: - ".editorconfig" jobs: + check-ford-docs: + name: Build Ford Docs + runs-on: ubuntu-latest + steps: + - name: Checkout + uses: actions/checkout@v4 + + - name: Build and Deploy Docs + uses: ./.github/actions/deploy-ford-docs + with: + ford-input: docs/Ford/ford-ci.md + doc-folder: docs/Ford/ci-doc + token: ${{ secrets.GITHUB_TOKEN }} + build_test_mapl: name: Build and Test MAPL GNU runs-on: ubuntu-latest diff --git a/CHANGELOG.md b/CHANGELOG.md index ce8d4744abe6..142b62deecac 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,7 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added -- Add glob function in sampler code, supporting wild character, e.g., filename template = amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4 +- Add glob function in sampler code, supporting wild character, e.g., filename template = `amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4` - Checked resource for o-server. It quits if the numer requested is inconsistent with being used - Replace local HorzIJIndex sear with the GlobalHorzIJindex search - Change grd_is_ok function to avoid collective call @@ -33,6 +33,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Add a new "SPLIT\_CHECKPOINT:" option that has replaced the write-by-face option. This will write a file per writer - Implemented a new algorthm to read tile files - Added two options, depends_on and depends_on_children, to ACG +- Add CI job to test Ford build (does not publish) ### Changed diff --git a/docs/Ford/ford-ci.md b/docs/Ford/ford-ci.md new file mode 100644 index 000000000000..f1b15f154fb5 --- /dev/null +++ b/docs/Ford/ford-ci.md @@ -0,0 +1,68 @@ +--- +preprocessor: cpp -traditional-cpp -E +src_dir: ../../ +output_dir: ci-doc +search: false +graph: false +coloured_edges: true +graph_maxdepth: 4 +graph_maxnodes: 32 +include: ../../include/ + ../../gFTL/install/GFTL-1.13/include/v1 + ../../gFTL/install/GFTL-1.13/include/v2 +exclude: **/EsmfRegridder.F90 + **/FieldBLAS_IntrinsicFunctions.F90 + **/GeomManager.F90 + **/MaplGeom.F90 + **/Regridder.F90 + **/StateSupplement.F90 +exclude_dir: ../../docs + ../../Doxygen + ../../ESMA_cmake + ../../ESMA_env + ../../build + ../../gFTL + ../../esmf + ../../pFUnit + ../../fArgParse + ../../pFlogger +macro: USE_MPI=1 + BUILD_WITH_PFLOGGER=1 + BUILD_WITH_EXTDATA2G=1 + USE_FLAP=1 + H5_HAVE_PARALLEL=1 + TWO_SIDED_COMM=1 + MAPL_MODE=1 +fixed_length_limit: false +source: true +display: public + private + protected +extra_mods: iso_fortran_env:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fFORTRAN_005fENV.html + iso_c_binding:https://gcc.gnu.org/onlinedocs/gfortran/ISO_005fC_005fBINDING.html#ISO_005fC_005fBINDING +external: remote = https://mathomp4.github.io/esmf +project: MAPL +project_github: https://github.com/GEOS-ESM/MAPL +project_website: https://github.com/GEOS-ESM/MAPL +summary: MAPL is a foundation layer of the GEOS architecture, whose original purpose is to supplement the Earth System Modeling Framework (ESMF) +author: The MAPL Developers +github: https://github.com/GEOS-ESM +email: matthew.thompson@nasa.gov +print_creation_date: true +sort: type-alpha +predocmark_alt: > +predocmark: < +docmark_alt: +docmark: ! +md_extensions: markdown.extensions.toc + markdown.extensions.smarty +extensions: f90 + F90 + pf +fpp_extensions: F90 + pf + F +externalize: true +--- + +{!../../README.md!} From 1b66b63263cacb0a73f994c053103a9c49a338eb Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 18 Apr 2024 14:47:45 -0400 Subject: [PATCH 130/141] refactoring.. --- pfio/MultiGroupServer.F90 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index b0dca25d2553..d8ccf4e193bd 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -811,6 +811,7 @@ subroutine start_back_writers(rc) enddo ! nfront call FileMetadata_deserialize(buffer_fmd, fmd) + deallocate (buffer_fmd) call thread_ptr%hist_collections%push_back(HistoryCollection(fmd)) @@ -832,16 +833,12 @@ subroutine start_back_writers(rc) call msg_iter%next() call array_ptr%destroy(_RC) call vars_map%erase(var_iter) - enddo - msg_iter = msg_map%begin() - do while (msg_iter /= msg_map%end()) - call msg_map%erase(msg_iter) - msg_iter = msg_map%begin() + call msg_map%erase(msg_iter) + msg_iter = msg_map%begin() enddo call thread_ptr%clear_hist_collections() call thread_ptr%hist_collections%clear() - deallocate (buffer_fmd) time = file_timer%get_total() file_size = file_size*4./1024./1024. ! 4-byte integer, unit is converted to MB From edbcf0098f93446b90a01686d18ea44a05682c9b Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Thu, 18 Apr 2024 15:08:40 -0400 Subject: [PATCH 131/141] Have to clear msg vector at the end. Not sure why. --- pfio/MultiGroupServer.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/pfio/MultiGroupServer.F90 b/pfio/MultiGroupServer.F90 index d8ccf4e193bd..77da6fb43348 100644 --- a/pfio/MultiGroupServer.F90 +++ b/pfio/MultiGroupServer.F90 @@ -833,6 +833,9 @@ subroutine start_back_writers(rc) call msg_iter%next() call array_ptr%destroy(_RC) call vars_map%erase(var_iter) + enddo + msg_iter = msg_map%begin() + do while (msg_iter /= msg_map%end()) call msg_map%erase(msg_iter) msg_iter = msg_map%begin() enddo From 9da2597597ef8201f68bf18d4d2472dedaa38791 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Fri, 19 Apr 2024 07:34:45 -0600 Subject: [PATCH 132/141] Backport Ford fixes from MAPL3 --- .github/actions/deploy-ford-docs/action.yml | 6 ++++-- .github/workflows/docs.yml | 12 ++++++++++-- .github/workflows/workflow.yml | 6 +++++- 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/.github/actions/deploy-ford-docs/action.yml b/.github/actions/deploy-ford-docs/action.yml index 9d69fbe2a0a5..94dee1da508a 100644 --- a/.github/actions/deploy-ford-docs/action.yml +++ b/.github/actions/deploy-ford-docs/action.yml @@ -61,12 +61,14 @@ runs: shell: bash - name: Build Documentation - run: ford ${{ inputs.ford-input }} + run: | + cd docs/Ford + ford ${{ inputs.ford-input }} shell: bash - name: Deploy Pages uses: JamesIves/github-pages-deploy-action@v4 - if: github.event_name == 'push' && github.repository == 'GEOS-ESM/MAPL' && ( startsWith( github.ref, 'refs/tags/v' ) || github.ref == 'refs/heads/main' ) + if: github.event_name == 'push' && github.repository == 'GEOS-ESM/MAPL' && ( startsWith( github.ref, 'refs/tags/v' ) || github.ref == 'refs/heads/main' || github.ref == 'refs/heads/release/MAPL-v3' ) with: folder: ${{ inputs.doc-folder }} token: ${{ inputs.token }} diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index bb73ea670da0..3e4740e794dc 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -21,7 +21,11 @@ jobs: - name: Build and Deploy Docs uses: ./.github/actions/deploy-ford-docs with: - ford-input: docs/Ford/docs-with-remote-esmf.md + # Due to a bug in ford, for now we do *not* want to use + # the full path to the ford input file. Rather, the + # action will cd into docs/Ford and then run ford + # relative path to the ford input file. + ford-input: docs-with-remote-esmf.md doc-folder: docs/Ford/doc token: ${{ secrets.GITHUB_TOKEN }} @@ -34,7 +38,11 @@ jobs: - name: Build and Deploy Dev Docs uses: ./.github/actions/deploy-ford-docs with: - ford-input: docs/Ford/docs-with-remote-esmf.public_private_protected.md + # Due to a bug in ford, for now we do *not* want to use + # the full path to the ford input file. Rather, the + # action will cd into docs/Ford and then run ford + # relative path to the ford input file. + ford-input: docs-with-remote-esmf.public_private_protected.md doc-folder: docs/Ford/dev-doc token: ${{ secrets.GITHUB_TOKEN }} target-folder: dev-doc diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 91260a1ec4f9..4c9ddc98a34e 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -23,7 +23,11 @@ jobs: - name: Build and Deploy Docs uses: ./.github/actions/deploy-ford-docs with: - ford-input: docs/Ford/ford-ci.md + # Due to a bug in ford, for now we do *not* want to use + # the full path to the ford input file. Rather, the + # action will cd into docs/Ford and then run ford + # relative path to the ford input file. + ford-input: ford-ci.md doc-folder: docs/Ford/ci-doc token: ${{ secrets.GITHUB_TOKEN }} From 4e69e9dc37d0d8ad609a302584fa5dad19f99b40 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang <52509753+weiyuan-jiang@users.noreply.github.com> Date: Fri, 19 Apr 2024 10:07:58 -0400 Subject: [PATCH 133/141] Update CHANGELOG.md --- CHANGELOG.md | 1 - 1 file changed, 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3447173f7ba0..2f7076193bbf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,7 +8,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added -<<<<<<< HEAD - Release the pfio memory as early as possible - Add glob function in sampler code, supporting wild character, e.g., filename template = `amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4` - Checked resource for o-server. It quits if the numer requested is inconsistent with being used From ee095a6c705c7e143e62ef0f2c20e953f8d401dd Mon Sep 17 00:00:00 2001 From: Yonggang Yu Date: Fri, 19 Apr 2024 13:46:15 -0600 Subject: [PATCH 134/141] Fixed a filename error in trajectory sampler, when wild character is introduced to file template --- CHANGELOG.md | 1 + .../Sampler/MAPL_TrajectoryMod_smod.F90 | 19 ++++++++++++++----- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 142b62deecac..4a6b667e001a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -9,6 +9,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Added +- Bug fix for filename with wild character in trajectory sampler - Add glob function in sampler code, supporting wild character, e.g., filename template = `amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4` - Checked resource for o-server. It quits if the numer requested is inconsistent with being used - Replace local HorzIJIndex sear with the GlobalHorzIJindex search diff --git a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 index 12c2c5060e69..4185dc8e1573 100644 --- a/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 +++ b/gridcomps/History/Sampler/MAPL_TrajectoryMod_smod.F90 @@ -43,7 +43,7 @@ character(len=ESMF_MAXSTR), allocatable :: word(:) integer :: nobs, head, jvar logical :: tend - integer :: i, j, k, M + integer :: i, j, k, k2, M integer :: count, idx integer :: unitr, unitw type(GriddedIOitem) :: item @@ -235,13 +235,22 @@ do i=1, traj%nobs_type call lgr%debug('%a %i4 %a %a', 'obs(', i, ') input_template =', & trim(traj%obs(i)%input_template)) - j=index(traj%obs(i)%input_template , '%') k=index(traj%obs(i)%input_template , '/', back=.true.) - _ASSERT(j>0, '% is not found, template is wrong') - traj%obs(i)%name = traj%obs(i)%input_template(k+1:j-1) + j=index(traj%obs(i)%input_template(k+1:), '%') + if (j>0) then + ! normal case: geos_atmosphere/aircraft.%y4%m2%d2T%h2%n2%S2Z.nc4 + traj%obs(i)%name = traj%obs(i)%input_template(k+1:k+j-1) + else + ! different case: Y%y4/M%m2/.../this.nc or ./this + k2=index(traj%obs(i)%input_template(k+1:), '.') + if (k2>0) then + traj%obs(i)%name = traj%obs(i)%input_template(k+1:k+k2) + else + traj%obs(i)%name = trim(traj%obs(i)%input_template(k+1:)) + end if + end if end do - _RETURN(_SUCCESS) 105 format (1x,a,2x,a) From 5761c673a4130c1d8dbfeca2759a291ec3d11007 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Mon, 22 Apr 2024 08:24:51 -0400 Subject: [PATCH 135/141] Update CHANGELOG.md --- CHANGELOG.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 2f7076193bbf..8022a253daec 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -55,7 +55,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Use GCC 11.4 as Intel backing compiler at NCCS SLES15 ### Fixed -- Change to IntArry's pointer to store data to avoid Intel Ifort's bug +- Change to IntArray's pointer to store data to avoid Intel Ifort bug - Fix inconsistency in History output so that multi-dimensional coordinate variables are also compressed if requested in the collection - Minor workaround to enable NAG 7.2.01 to compile. (Reproducer submitted to NAG.) - Fixed bug with split restart files From 76d6e17531414fd712d2ab132695c14ed3b92734 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 23 Apr 2024 09:27:13 -0400 Subject: [PATCH 136/141] Add missing c_ptr declaration --- field_utils/tests/Test_FieldBLAS.pf | 1 + 1 file changed, 1 insertion(+) diff --git a/field_utils/tests/Test_FieldBLAS.pf b/field_utils/tests/Test_FieldBLAS.pf index f17f0c9b330c..24c0fe6f810e 100644 --- a/field_utils/tests/Test_FieldBLAS.pf +++ b/field_utils/tests/Test_FieldBLAS.pf @@ -8,6 +8,7 @@ module Test_FieldBLAS use ESMF use pfunit use MAPL_ExceptionHandling + use, intrinsic :: iso_c_binding, only: c_ptr implicit none From 85737e23fd8f152bb7401a805ff689e175cdd53f Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 23 Apr 2024 12:22:59 -0400 Subject: [PATCH 137/141] Update GitHub Actions to use GCC 13.2 --- .github/workflows/workflow.yml | 2 +- CHANGELOG.md | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/workflows/workflow.yml b/.github/workflows/workflow.yml index 4c9ddc98a34e..1ac68d8fcf35 100644 --- a/.github/workflows/workflow.yml +++ b/.github/workflows/workflow.yml @@ -35,7 +35,7 @@ jobs: name: Build and Test MAPL GNU runs-on: ubuntu-latest container: - image: gmao/ubuntu20-geos-env-mkl:v7.23.0-openmpi_5.0.0-gcc_12.1.0 + image: gmao/ubuntu20-geos-env-mkl:v7.23.0-openmpi_5.0.2-gcc_13.2.0 # Per https://github.com/actions/virtual-environments/issues/1445#issuecomment-713861495 # It seems like we might not need secrets on GitHub Actions which is good for forked # pull requests diff --git a/CHANGELOG.md b/CHANGELOG.md index 4a6b667e001a..dd2104994c4d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -54,6 +54,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Updates to GFE v1.15 - Fixes for NAG - Use GCC 11.4 as Intel backing compiler at NCCS SLES15 +- Update CI to use Baselibs 7.23.0 and GCC 13.2 for GNU tests ### Fixed From dd341a3ce9302e01877eaec59e807d79396d624c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Tue, 23 Apr 2024 14:42:05 -0400 Subject: [PATCH 138/141] Remove macOS + Intel CMake logic --- CHANGELOG.md | 2 ++ MAPL_cfio/CMakeLists.txt | 17 +---------------- 2 files changed, 3 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index dd2104994c4d..4b95555ef412 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -66,6 +66,8 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Removed +- Removed CMake logic for macOS + Intel as that is an unsupported configuration + ### Deprecated ## [2.44.3] - 2024-03-28 diff --git a/MAPL_cfio/CMakeLists.txt b/MAPL_cfio/CMakeLists.txt index 01ccb4b5e8c2..16d5f4b931c3 100644 --- a/MAPL_cfio/CMakeLists.txt +++ b/MAPL_cfio/CMakeLists.txt @@ -27,25 +27,10 @@ set (EOS ) set (lib MAPL_cfio_${precision}) -if (APPLE AND CMAKE_Fortran_COMPILER_ID MATCHES Intel AND CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 20.2.1) - set (LIBRARY_TYPE STATIC) - ecbuild_warn ( - "Found Intel oneAPI on macOS.\n" - "MAPL developers have found an issue with Intel oneAPI on macOS\n" - "where GEOSgcm.x would not work. Debugging found the issue was\n" - "that command_argument_count() would return -1 which should *NEVER*\n" - "happen per Fortran Standard and then this broke FLAP.\n" - "A workaround was found that if the ${this} library was compiled\n" - "as TYPE STATIC, the model would work. So we are setting ${this} as\n" - "a TYPE STATIC library. Note: This might interfere with coupled model.") -else () - set (LIBRARY_TYPE ${MAPL_LIBRARY_TYPE}) -endif () - esma_add_library (${lib} SRCS ${srcs} DEPENDENCIES ESMF::ESMF NetCDF::NetCDF_Fortran - TYPE ${LIBRARY_TYPE} + TYPE ${MAPL_LIBRARY_TYPE} ) if (precision MATCHES "r8") From 366bb81d1d41a51be7273d43c1b553ec4c98e325 Mon Sep 17 00:00:00 2001 From: Weiyuan Jiang Date: Wed, 24 Apr 2024 14:43:17 -0400 Subject: [PATCH 139/141] change data to private --- pfio/IntArray.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/pfio/IntArray.F90 b/pfio/IntArray.F90 index 8783578b1c53..7e3b76337e32 100644 --- a/pfio/IntArray.F90 +++ b/pfio/IntArray.F90 @@ -26,6 +26,7 @@ module pFIO_IntArrayMod public :: IntArray type :: IntArray + private integer, pointer :: values(:) contains procedure :: get_values From 4e0cd927ffedc0a05e9a9827d6b0593871d1a110 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 25 Apr 2024 10:36:09 -0400 Subject: [PATCH 140/141] Prepare for 2.45.0 Release --- CHANGELOG.md | 20 +++++++++++++++++--- CMakeLists.txt | 2 +- 2 files changed, 18 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8ec1a3a803be..35bc106b345f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -8,7 +8,21 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] ### Added -- Release the pfio memory as early as possible + +### Changed + +### Fixed + +### Removed + +- Removed CMake logic for macOS + Intel as that is an unsupported configuration + +### Deprecated + +## [2.45.0] - 2024-04-25 + +### Added + - Add glob function in sampler code, supporting wild character, e.g., filename template = `amsr2_gcom-w1.%y4%m2%d2T%h2%n2*.nc4` - Checked resource for o-server. It quits if the numer requested is inconsistent with being used - Replace local HorzIJIndex sear with the GlobalHorzIJindex search @@ -37,6 +51,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +- Release the pfio memory as early as possible - Trajectory sampler: ls_rt -> ls_chunk (via mpi_gatherV) -> ls_distributed(bk=cs_grid; via ESMF_FieldRedistStore), aiming to save computational time. To gather 3D data via mpi, options for level by level and single-3D are added via ifdef. - The MAPL\_ESMFRegridder manage now does compute the transpose by default - Bypassed the I-Server reading call when there is no extdata @@ -56,6 +71,7 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Update CI to use Baselibs 7.23.0 and GCC 13.2 for GNU tests ### Fixed + - Change to IntArray's pointer to store data to avoid Intel Ifort bug - Fix inconsistency in History output so that multi-dimensional coordinate variables are also compressed if requested in the collection - Minor workaround to enable NAG 7.2.01 to compile. (Reproducer submitted to NAG.) @@ -67,8 +83,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 - Removed CMake logic for macOS + Intel as that is an unsupported configuration -### Deprecated - ## [2.44.3] - 2024-03-28 ### Fixed diff --git a/CMakeLists.txt b/CMakeLists.txt index 96875bfee68a..1ae38e18a764 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -8,7 +8,7 @@ endif () project ( MAPL - VERSION 2.44.3 + VERSION 2.45.0 LANGUAGES Fortran CXX C) # Note - CXX is required for ESMF # Set the possible values of build type for cmake-gui From eef79547f0f89ab22606637b8e26389fb50f11c0 Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Thu, 25 Apr 2024 12:11:27 -0400 Subject: [PATCH 141/141] Fix changelog --- CHANGELOG.md | 2 -- 1 file changed, 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 35bc106b345f..4a726f42c23e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,8 +15,6 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Removed -- Removed CMake logic for macOS + Intel as that is an unsupported configuration - ### Deprecated ## [2.45.0] - 2024-04-25