From a8df70292c3c44272f74a3f84dccb35b1bcf65ab Mon Sep 17 00:00:00 2001 From: danholdaway Date: Fri, 23 Jul 2021 10:15:24 -0400 Subject: [PATCH 1/4] JCSDA changes --- field_manager/field_manager.F90 | 2 +- fms/fms.F90 | 15 ++- fms/fms_io.F90 | 16 +++- mpp/include/mpp_comm_mpi.inc | 9 +- mpp/include/mpp_comm_nocomm.inc | 9 +- mpp/include/mpp_do_update_ad.h | 153 ++++++++++++++++++++++-------- mpp/include/mpp_util.inc | 9 +- tracer_manager/tracer_manager.F90 | 2 +- 8 files changed, 158 insertions(+), 57 deletions(-) diff --git a/field_manager/field_manager.F90 b/field_manager/field_manager.F90 index 686549886a..dc4234ff0e 100644 --- a/field_manager/field_manager.F90 +++ b/field_manager/field_manager.F90 @@ -275,7 +275,7 @@ module field_manager_mod !> The length of a character string representing the field path. integer, parameter, public :: fm_path_name_len = 512 !> The length of a character string representing character values for the field. -integer, parameter, public :: fm_string_len = 128 +integer, parameter, public :: fm_string_len = 1024 !> The length of a character string representing the various types that the values of the field can take. integer, parameter, public :: fm_type_name_len = 8 !> Number of models (ATMOS, OCEAN, LAND, ICE, COUPLER). diff --git a/fms/fms.F90 b/fms/fms.F90 index 2755bcfd8e..d14533a2d6 100644 --- a/fms/fms.F90 +++ b/fms/fms.F90 @@ -321,13 +321,14 @@ module fms_mod !! The namelist variable clock_grain must be one of the following values: !! 'NONE', 'COMPONENT', 'SUBCOMPONENT', 'MODULE_DRIVER', 'MODULE', 'ROUTINE', !! 'LOOP', or 'INFRA' (case-insensitive). -subroutine fms_init (localcomm ) +subroutine fms_init (localcomm, alt_input_nml_path) !--- needed to output the version number of constants_mod to the logfile --- use constants_mod, only: constants_version=>version !pjp: PI not computed use fms_io_mod, only: fms_io_version integer, intent(in), optional :: localcomm + character(len=*), intent(in), optional :: alt_input_nml_path integer :: unit, ierr, io integer :: logunitnum @@ -335,9 +336,17 @@ subroutine fms_init (localcomm ) module_is_initialized = .true. !---- initialize mpp routines ---- if(present(localcomm)) then - call mpp_init(localcomm=localcomm) + if(present(alt_input_nml_path)) then + call mpp_init(localcomm=localcomm, alt_input_nml_path=alt_input_nml_path) + else + call mpp_init(localcomm=localcomm) + endif else - call mpp_init() + if(present(alt_input_nml_path)) then + call mpp_init(alt_input_nml_path=alt_input_nml_path) + else + call mpp_init() + endif endif call mpp_domains_init() call fms_io_init() diff --git a/fms/fms_io.F90 b/fms/fms_io.F90 index b2f67c460f..9a8ca19457 100644 --- a/fms/fms_io.F90 +++ b/fms/fms_io.F90 @@ -137,7 +137,7 @@ module fms_io_mod integer, parameter, private :: max_fields=400 integer, parameter, private :: max_axes=40 integer, parameter, private :: max_atts=20 -integer, parameter, private :: max_domains = 10 +integer, parameter, private :: max_domains = 1000 integer, parameter, private :: MAX_TIME_LEVEL_REGISTER = 2 integer, parameter, private :: MAX_TIME_LEVEL_WRITE = 20 integer, parameter :: max_axis_size=10000 @@ -721,8 +721,9 @@ subroutine fms_io_init() end select ! Initially allocate files_write and files_read - allocate(files_write(max_files_w),files_read(max_files_r)) - allocate(registered_file(max_files_w)) + if (.not. allocated(files_write) ) allocate(files_write(max_files_w)) + if (.not. allocated(files_read) ) allocate(files_read(max_files_r)) + if (.not. allocated(registered_file)) allocate(registered_file(max_files_w)) do i = 1, max_domains array_domain(i) = NULL_DOMAIN2D @@ -7904,11 +7905,12 @@ end subroutine get_mosaic_tile_file_ug !############################################################################# - subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count) + subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count, custom_path) character(len=*), intent(out) :: grid_file character(len=*), intent(in) :: mosaic_file type(domain2D), intent(in) :: domain integer, intent(in), optional :: tile_count + character(len=*), intent(in), optional :: custom_path integer :: tile, ntileMe integer, dimension(:), allocatable :: tile_id @@ -7918,7 +7920,11 @@ subroutine get_mosaic_tile_grid(grid_file, mosaic_file, domain, tile_count) allocate(tile_id(ntileMe)) tile_id = mpp_get_tile_id(domain) call read_data(mosaic_file, "gridfiles", grid_file, level=tile_id(tile) ) - grid_file = 'INPUT/'//trim(grid_file) + if (.not. present(custom_path)) then + grid_file = 'INPUT/'//trim(grid_file) + else + grid_file = trim(custom_path)//'/'//trim(grid_file) + endif deallocate(tile_id) end subroutine get_mosaic_tile_grid diff --git a/mpp/include/mpp_comm_mpi.inc b/mpp/include/mpp_comm_mpi.inc index 4dd0d0daa6..0457a96a85 100644 --- a/mpp/include/mpp_comm_mpi.inc +++ b/mpp/include/mpp_comm_mpi.inc @@ -30,10 +30,11 @@ ! subroutine mpp_init( flags, in, out, err, log ) ! integer, optional, intent(in) :: flags, in, out, err, log !> @brief Initialize the @ref mpp_mod module - subroutine mpp_init( flags, localcomm, test_level ) + subroutine mpp_init( flags, localcomm, test_level, alt_input_nml_path ) integer, optional, intent(in) :: flags integer, optional, intent(in) :: localcomm integer, optional, intent(in) :: test_level + character(len=*), optional, intent(in) :: alt_input_nml_path integer :: my_pe, num_pes, len, i, iunit logical :: opened, existed integer :: unit_begin, unit_end, unit_nml, io_status @@ -111,7 +112,11 @@ if (t_level == 3) return call mpp_init_logfile() - call read_input_nml + if (present(alt_input_nml_path)) then + call read_input_nml(alt_input_nml_path=alt_input_nml_path) + else + call read_input_nml + end if if (t_level == 4) return !--- read namelist diff --git a/mpp/include/mpp_comm_nocomm.inc b/mpp/include/mpp_comm_nocomm.inc index b525a08511..4a8a1417ad 100644 --- a/mpp/include/mpp_comm_nocomm.inc +++ b/mpp/include/mpp_comm_nocomm.inc @@ -31,9 +31,10 @@ ! subroutine mpp_init( flags, in, out, err, log ) ! integer, optional, intent(in) :: flags, in, out, err, log !> @brief Initialize the @ref mpp_mod module -subroutine mpp_init( flags,localcomm ) +subroutine mpp_init( flags,localcomm, alt_input_nml_path ) integer, optional, intent(in) :: flags integer, optional, intent(in) :: localcomm ! dummy here, used only in MPI + character(len=*), optional, intent(in) :: alt_input_nml_path integer :: my_pe, num_pes, len, i, logunit logical :: opened, existed integer :: unit_begin, unit_end, unit_nml, io_status @@ -86,7 +87,11 @@ subroutine mpp_init( flags,localcomm ) end if call mpp_init_logfile() - call read_input_nml + if (present(alt_input_nml_path)) then + call read_input_nml(alt_input_nml_path=alt_input_nml_path) + else + call read_input_nml + end if !--- read namelist #ifdef INTERNAL_FILE_NML diff --git a/mpp/include/mpp_do_update_ad.h b/mpp/include/mpp_do_update_ad.h index 17b01cdd5a..e7199c8105 100644 --- a/mpp/include/mpp_do_update_ad.h +++ b/mpp/include/mpp_do_update_ad.h @@ -42,9 +42,9 @@ !receive domains saved here for unpacking !for non-blocking version, could be recomputed - integer, allocatable :: msg1(:), msg2(:) + integer, allocatable :: msg1(:), msg2(:), msg3(:) logical :: send(8), recv(8), update_edge_only - integer :: to_pe, from_pe, pos, msgsize, msgsize_send + integer :: to_pe, from_pe, pos, msgsize integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir integer :: start, start1, start2, index, is1, ie1, js1, je1, ni, nj, total @@ -52,7 +52,6 @@ integer :: send_start_pos integer :: send_msgsize(MAXLIST) - outunit = stdout() ptr = LOC(mpp_domains_stack) l_size = size(f_addrs,1) @@ -81,10 +80,11 @@ send = recv if(debug_message_passing) then - nlist = size(domain%list(:)) - allocate(msg1(0:nlist-1), msg2(0:nlist-1) ) + nlist = size(domain%list(:)) + allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) msg1 = 0 msg2 = 0 + msg3 = 0 do m = 1, update%nrecv overPtr => update%recv(m) msgsize = 0 @@ -98,7 +98,6 @@ end do from_pe = update%recv(m)%pe l = from_pe-mpp_root_pe() - call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1 ) msg2(l) = msgsize enddo @@ -113,9 +112,10 @@ msgsize = msgsize + (ie-is+1)*(je-js+1) end if end do - call mpp_send( msgsize, plen=1, to_pe=overPtr%pe, tag=COMM_TAG_1 ) + l = overPtr%pe - mpp_root_pe() + msg3(l) = msgsize enddo - call mpp_sync_self(check=EVENT_RECV) + call mpp_alltoall(msg3, 1, msg1, 1) do m = 0, nlist-1 if(msg1(m) .NE. msg2(m)) then @@ -124,10 +124,9 @@ call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size") endif enddo - call mpp_sync_self() write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " & //trim(domain%name) - deallocate(msg1, msg2) + deallocate(msg1, msg2, msg3) endif !recv @@ -139,38 +138,26 @@ do n = 1, overPtr%count dir = overPtr%dir(n) if(recv(dir)) then - tMe = overPtr%tileMe(n) is = overPtr%is(n); ie = overPtr%ie(n) js = overPtr%js(n); je = overPtr%je(n) msgsize = msgsize + (ie-is+1)*(je-js+1) - msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size - pos = buffer_pos + msgsize_send - do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) - do k = ke,1,-1 - do j = je, js, -1 - do i = ie, is, -1 - buffer(pos) = field(i,j,k) - field(i,j,k) = 0. - pos = pos - 1 - end do - end do - end do - end do end if end do msgsize = msgsize*ke*l_size if( msgsize.GT.0 )then - to_pe = overPtr%pe - call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if end do ! end do m = 1, update%nrecv buffer_recv_size = buffer_pos + send_start_pos = buffer_pos - ! send + ! send info + !---------------------------------------------------------------------- + buffer_pos = buffer_recv_size + ! pack do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -181,19 +168,100 @@ enddo if( msgsize.GT.0 )then msgsize = msgsize*ke*l_size - msgsize_send = msgsize + end if + + do n = 1, overPtr%count + dir = overPtr%dir(n) + if( send(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + pos = pos + (ie-is+1)*(je-js+1)*ke*l_size + endif + end do ! do n = 1, overPtr%count + + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do ! end do m = 1, nsend + + !backward communication + !---------------------------------------------------------------------- + !recv + buffer_pos = buffer_recv_size + do m = update%nrecv, 1, -1 + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + pos = buffer_pos + do n = overPtr%count, 1, -1 + dir = overPtr%dir(n) + if( recv(dir) ) then + tMe = overPtr%tileMe(n) + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = (ie-is+1)*(je-js+1)*ke*l_size + pos = buffer_pos - msgsize + buffer_pos = pos + do l=1,l_size ! loop over number of fields + ptr_field = f_addrs(l, tMe) + do k = 1,ke + do j = js, je + do i = is, ie + pos = pos + 1 + buffer(pos) = field(i,j,k) + end do + end do + end do + end do + endif + end do ! do n = 1, overPtr%count + end do + + !---------------------------------------------------------------------- + buffer_pos = send_start_pos + do m = 1, update%nsend + msgsize = send_msgsize(m) + if(msgsize == 0) cycle + to_pe = update%send(m)%pe + call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_2 ) + buffer_pos = buffer_pos + msgsize + end do ! end do ist = 0,nlist-1 + + !---------------------------------------------------------------------- + !recv + buffer_pos = 0 + do m = 1, update%nrecv + overPtr => update%recv(m) + if( overPtr%count == 0 )cycle + msgsize = 0 + do n = 1, overPtr%count + dir = overPtr%dir(n) + if(recv(dir)) then + is = overPtr%is(n); ie = overPtr%ie(n) + js = overPtr%js(n); je = overPtr%je(n) + msgsize = msgsize + (ie-is+1)*(je-js+1) + end if + end do + + msgsize = msgsize*ke*l_size + if( msgsize.GT.0 )then from_pe = overPtr%pe - call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 ) + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' ) + end if + call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do ist = 0,nlist-1 + end do ! end do m = 1, update%nrecv call mpp_sync_self(check=EVENT_RECV) + !---------------------------------------------------------------------- buffer_pos = buffer_recv_size - - ! send do m = 1, update%nsend + send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -203,7 +271,13 @@ if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n) enddo if( msgsize.GT.0 )then - buffer_pos = pos + msgsize = msgsize*ke*l_size + mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize ) + if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then + write( text,'(i8)' )mpp_domains_stack_hwm + call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // & + 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.') + end if end if do n = 1, overPtr%count @@ -261,15 +335,12 @@ end do end do end do - end select + end select endif end do ! do n = 1, overPtr%count - - msgsize = pos - buffer_pos - if( msgsize.GT.0 )then - buffer_pos = pos - end if - end do ! end do ist = 0,nlist-1 + send_msgsize(m) = pos-buffer_pos + buffer_pos = pos + end do ! end do m = 1, nsend call mpp_sync_self() diff --git a/mpp/include/mpp_util.inc b/mpp/include/mpp_util.inc index 55201157d6..031b706e34 100644 --- a/mpp/include/mpp_util.inc +++ b/mpp/include/mpp_util.inc @@ -1310,12 +1310,13 @@ end function rarray_to_char ! read(input_nml_file, nml=, iostat=status) ! ! - subroutine read_input_nml(pelist_name_in) + subroutine read_input_nml(pelist_name_in, alt_input_nml_path) ! Include variable "version" to be written to log file. #include character(len=*), intent(in), optional :: pelist_name_in + character(len=*), intent(in), optional :: alt_input_nml_path ! private variables integer :: log_unit integer :: i @@ -1344,7 +1345,11 @@ end function rarray_to_char filename='input_'//trim(pelist_name)//'.nml' inquire(FILE=filename, EXIST=file_exist) if (.not. file_exist ) then - filename='input.nml' + if (present(alt_input_nml_path)) then + filename = alt_input_nml_path + else + filename = 'input.nml' + end if endif lines_and_length = get_ascii_file_num_lines_and_length(filename) allocate(character(len=lines_and_length(2))::input_nml_file(lines_and_length(1))) diff --git a/tracer_manager/tracer_manager.F90 b/tracer_manager/tracer_manager.F90 index 7534f5d6a5..79ea8ac623 100644 --- a/tracer_manager/tracer_manager.F90 +++ b/tracer_manager/tracer_manager.F90 @@ -159,7 +159,7 @@ module tracer_manager_mod !> @{ integer :: num_tracer_fields = 0 -integer, parameter :: MAX_TRACER_FIELDS = 150 +integer, parameter :: MAX_TRACER_FIELDS = 250 integer, parameter :: MAX_TRACER_METHOD = 20 integer, parameter :: NO_TRACER = 1-HUGE(1) integer, parameter :: NOTRACER = -HUGE(1) From 1c984ebcea8e28794cfda8550b9c3938a773ed84 Mon Sep 17 00:00:00 2001 From: danholdaway Date: Mon, 26 Jul 2021 11:08:52 -0400 Subject: [PATCH 2/4] Remove trailing whitespace in mpp/include/mpp_do_update_ad.h --- mpp/include/mpp_do_update_ad.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/mpp/include/mpp_do_update_ad.h b/mpp/include/mpp_do_update_ad.h index e7199c8105..ff3a9912d6 100644 --- a/mpp/include/mpp_do_update_ad.h +++ b/mpp/include/mpp_do_update_ad.h @@ -80,7 +80,7 @@ send = recv if(debug_message_passing) then - nlist = size(domain%list(:)) + nlist = size(domain%list(:)) allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) msg1 = 0 msg2 = 0 @@ -154,7 +154,7 @@ ! send info !---------------------------------------------------------------------- - buffer_pos = buffer_recv_size + buffer_pos = buffer_recv_size ! pack do m = 1, update%nsend send_msgsize(m) = 0 @@ -183,7 +183,7 @@ send_msgsize(m) = pos-buffer_pos buffer_pos = pos end do ! end do m = 1, nsend - + !backward communication !---------------------------------------------------------------------- !recv From 98185e171d400d67f30a51410c8688118ec30cc3 Mon Sep 17 00:00:00 2001 From: danholdaway Date: Thu, 2 Sep 2021 10:44:09 -0400 Subject: [PATCH 3/4] revert adjoint --- mpp/include/mpp_do_update_ad.h | 151 +++++++++------------------------ 1 file changed, 40 insertions(+), 111 deletions(-) diff --git a/mpp/include/mpp_do_update_ad.h b/mpp/include/mpp_do_update_ad.h index ff3a9912d6..17b01cdd5a 100644 --- a/mpp/include/mpp_do_update_ad.h +++ b/mpp/include/mpp_do_update_ad.h @@ -42,9 +42,9 @@ !receive domains saved here for unpacking !for non-blocking version, could be recomputed - integer, allocatable :: msg1(:), msg2(:), msg3(:) + integer, allocatable :: msg1(:), msg2(:) logical :: send(8), recv(8), update_edge_only - integer :: to_pe, from_pe, pos, msgsize + integer :: to_pe, from_pe, pos, msgsize, msgsize_send integer :: n, l_size, l, m, i, j, k integer :: is, ie, js, je, tMe, dir integer :: start, start1, start2, index, is1, ie1, js1, je1, ni, nj, total @@ -52,6 +52,7 @@ integer :: send_start_pos integer :: send_msgsize(MAXLIST) + outunit = stdout() ptr = LOC(mpp_domains_stack) l_size = size(f_addrs,1) @@ -81,10 +82,9 @@ if(debug_message_passing) then nlist = size(domain%list(:)) - allocate(msg1(0:nlist-1), msg2(0:nlist-1), msg3(0:nlist-1) ) + allocate(msg1(0:nlist-1), msg2(0:nlist-1) ) msg1 = 0 msg2 = 0 - msg3 = 0 do m = 1, update%nrecv overPtr => update%recv(m) msgsize = 0 @@ -98,6 +98,7 @@ end do from_pe = update%recv(m)%pe l = from_pe-mpp_root_pe() + call mpp_recv( msg1(l), glen=1, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_1 ) msg2(l) = msgsize enddo @@ -112,10 +113,9 @@ msgsize = msgsize + (ie-is+1)*(je-js+1) end if end do - l = overPtr%pe - mpp_root_pe() - msg3(l) = msgsize + call mpp_send( msgsize, plen=1, to_pe=overPtr%pe, tag=COMM_TAG_1 ) enddo - call mpp_alltoall(msg3, 1, msg1, 1) + call mpp_sync_self(check=EVENT_RECV) do m = 0, nlist-1 if(msg1(m) .NE. msg2(m)) then @@ -124,9 +124,10 @@ call mpp_error(FATAL, "mpp_do_update: mismatch on send and recv size") endif enddo + call mpp_sync_self() write(outunit,*)"NOTE from mpp_do_update: message sizes are matched between send and recv for domain " & //trim(domain%name) - deallocate(msg1, msg2, msg3) + deallocate(msg1, msg2) endif !recv @@ -138,26 +139,38 @@ do n = 1, overPtr%count dir = overPtr%dir(n) if(recv(dir)) then + tMe = overPtr%tileMe(n) is = overPtr%is(n); ie = overPtr%ie(n) js = overPtr%js(n); je = overPtr%je(n) msgsize = msgsize + (ie-is+1)*(je-js+1) + msgsize_send = (ie-is+1)*(je-js+1)*ke*l_size + pos = buffer_pos + msgsize_send + do l=1,l_size ! loop over number of fields + ptr_field = f_addrs(l, tMe) + do k = ke,1,-1 + do j = je, js, -1 + do i = ie, is, -1 + buffer(pos) = field(i,j,k) + field(i,j,k) = 0. + pos = pos - 1 + end do + end do + end do + end do end if end do msgsize = msgsize*ke*l_size if( msgsize.GT.0 )then + to_pe = overPtr%pe + call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=to_pe, tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if end do ! end do m = 1, update%nrecv buffer_recv_size = buffer_pos - send_start_pos = buffer_pos - ! send info - !---------------------------------------------------------------------- - buffer_pos = buffer_recv_size - ! pack + ! send do m = 1, update%nsend - send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -168,100 +181,19 @@ enddo if( msgsize.GT.0 )then msgsize = msgsize*ke*l_size - end if - - do n = 1, overPtr%count - dir = overPtr%dir(n) - if( send(dir) ) then - tMe = overPtr%tileMe(n) - is = overPtr%is(n); ie = overPtr%ie(n) - js = overPtr%js(n); je = overPtr%je(n) - pos = pos + (ie-is+1)*(je-js+1)*ke*l_size - endif - end do ! do n = 1, overPtr%count - - send_msgsize(m) = pos-buffer_pos - buffer_pos = pos - end do ! end do m = 1, nsend - - !backward communication - !---------------------------------------------------------------------- - !recv - buffer_pos = buffer_recv_size - do m = update%nrecv, 1, -1 - overPtr => update%recv(m) - if( overPtr%count == 0 )cycle - pos = buffer_pos - do n = overPtr%count, 1, -1 - dir = overPtr%dir(n) - if( recv(dir) ) then - tMe = overPtr%tileMe(n) - is = overPtr%is(n); ie = overPtr%ie(n) - js = overPtr%js(n); je = overPtr%je(n) - msgsize = (ie-is+1)*(je-js+1)*ke*l_size - pos = buffer_pos - msgsize - buffer_pos = pos - do l=1,l_size ! loop over number of fields - ptr_field = f_addrs(l, tMe) - do k = 1,ke - do j = js, je - do i = is, ie - pos = pos + 1 - buffer(pos) = field(i,j,k) - end do - end do - end do - end do - endif - end do ! do n = 1, overPtr%count - end do - - !---------------------------------------------------------------------- - buffer_pos = send_start_pos - do m = 1, update%nsend - msgsize = send_msgsize(m) - if(msgsize == 0) cycle - to_pe = update%send(m)%pe - call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=to_pe, block=.FALSE., tag=COMM_TAG_2 ) - buffer_pos = buffer_pos + msgsize - end do ! end do ist = 0,nlist-1 - - !---------------------------------------------------------------------- - !recv - buffer_pos = 0 - do m = 1, update%nrecv - overPtr => update%recv(m) - if( overPtr%count == 0 )cycle - msgsize = 0 - do n = 1, overPtr%count - dir = overPtr%dir(n) - if(recv(dir)) then - is = overPtr%is(n); ie = overPtr%ie(n) - js = overPtr%js(n); je = overPtr%je(n) - msgsize = msgsize + (ie-is+1)*(je-js+1) - end if - end do - - msgsize = msgsize*ke*l_size - if( msgsize.GT.0 )then + msgsize_send = msgsize from_pe = overPtr%pe - mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, (buffer_pos+msgsize) ) - if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then - write( text,'(i8)' )mpp_domains_stack_hwm - call mpp_error( FATAL, 'MPP_DO_UPDATE: mpp_domains_stack overflow, '// & - 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.' ) - end if - call mpp_send( buffer(buffer_pos+1), plen=msgsize, to_pe=from_pe, tag=COMM_TAG_2 ) + call mpp_recv( buffer(buffer_pos+1), glen=msgsize, from_pe=from_pe, block=.FALSE., tag=COMM_TAG_2 ) buffer_pos = buffer_pos + msgsize end if - end do ! end do m = 1, update%nrecv + end do ! end do ist = 0,nlist-1 call mpp_sync_self(check=EVENT_RECV) - !---------------------------------------------------------------------- buffer_pos = buffer_recv_size + + ! send do m = 1, update%nsend - send_msgsize(m) = 0 overPtr => update%send(m) if( overPtr%count == 0 )cycle pos = buffer_pos @@ -271,13 +203,7 @@ if( send(dir) ) msgsize = msgsize + overPtr%msgsize(n) enddo if( msgsize.GT.0 )then - msgsize = msgsize*ke*l_size - mpp_domains_stack_hwm = max( mpp_domains_stack_hwm, pos+msgsize ) - if( mpp_domains_stack_hwm.GT.mpp_domains_stack_size )then - write( text,'(i8)' )mpp_domains_stack_hwm - call mpp_error( FATAL, 'MPP_START_UPDATE_DOMAINS: mpp_domains_stack overflow, ' // & - 'call mpp_domains_set_stack_size('//trim(text)//') from all PEs.') - end if + buffer_pos = pos end if do n = 1, overPtr%count @@ -335,12 +261,15 @@ end do end do end do - end select + end select endif end do ! do n = 1, overPtr%count - send_msgsize(m) = pos-buffer_pos - buffer_pos = pos - end do ! end do m = 1, nsend + + msgsize = pos - buffer_pos + if( msgsize.GT.0 )then + buffer_pos = pos + end if + end do ! end do ist = 0,nlist-1 call mpp_sync_self() From b8158cd8d0864bcafa4b099c6faaa0692fcb7139 Mon Sep 17 00:00:00 2001 From: danholdaway Date: Tue, 7 Sep 2021 11:17:14 -0400 Subject: [PATCH 4/4] reduce max_domains --- fms/fms_io.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fms/fms_io.F90 b/fms/fms_io.F90 index 05364e2db1..f135e53730 100644 --- a/fms/fms_io.F90 +++ b/fms/fms_io.F90 @@ -137,7 +137,7 @@ module fms_io_mod integer, parameter, private :: max_fields=400 integer, parameter, private :: max_axes=40 integer, parameter, private :: max_atts=20 -integer, parameter, private :: max_domains = 1000 +integer, parameter, private :: max_domains = 100 integer, parameter, private :: MAX_TIME_LEVEL_REGISTER = 2 integer, parameter, private :: MAX_TIME_LEVEL_WRITE = 20 integer, parameter :: max_axis_size=10000