Merge branch 'user/nnz/fix_trajectory_append_hang' into dev/master

Conflicts:
	icebergs_framework.F90

icebergs_framework.F90

@@ -39,12 +39,14 @@ module ice_bergs_framework
 real, parameter :: pi_180=pi/180. ! Converts degrees to radians
 logical :: fix_restart_dates=.true. ! After a restart, check that bergs were created before the current model date
 logical :: do_unit_tests=.false. ! Conduct some unit tests
+logical :: force_all_pes_traj=.false. ! Force all pes write trajectory files regardless of io_layout
+logical :: reverse_traj=.false. ! Force trajectories to be written in reverse order into files to save time
 
 !Public params !Niki: write a subroutine to expose these
 public nclasses,buffer_width,buffer_width_traj
 public verbose, really_debug, debug, restart_input_dir,make_calving_reproduce,old_bug_bilin,use_roundoff_fix
 public ignore_ij_restart, use_slow_find,generate_test_icebergs,old_bug_rotated_weights,budget
-public orig_read
+public orig_read, force_all_pes_traj, reverse_traj
 
 
 !Public types
@@ -65,6 +67,7 @@ module ice_bergs_framework
 public checksum_gridded
 public grd_chksum2,grd_chksum3
 public fix_restart_dates, offset_berg_dates
+public reverse_list
 
 type :: icebergs_gridded
   type(domain2D), pointer :: domain ! MPP domain
@@ -164,6 +167,7 @@ module ice_bergs_framework
   integer :: traj_sample_hrs, traj_write_hrs
   integer :: verbose_hrs
   integer :: clock, clock_mom, clock_the, clock_int, clock_cal, clock_com, clock_ini, clock_ior, clock_iow, clock_dia ! ids for fms timers
+  integer :: clock_trw, clock_trp
   real :: rho_bergs ! Density of icebergs [kg/m^3]
   real :: LoW_ratio ! Initial ratio L/W for newly calved icebergs
   real :: bergy_bit_erosion_fraction ! Fraction of erosion melt flux to divert to bergy bits
@@ -276,7 +280,8 @@ subroutine ice_bergs_framework_init(bergs, &
          rho_bergs, LoW_ratio, debug, really_debug, use_operator_splitting, bergy_bit_erosion_fraction, &
          parallel_reprod, use_slow_find, sicn_shift, add_weight_to_ocean, passive_mode, ignore_ij_restart, &
          time_average_weight, generate_test_icebergs, speed_limit, fix_restart_dates, use_roundoff_fix, &
-         old_bug_rotated_weights, make_calving_reproduce,restart_input_dir, orig_read, old_bug_bilin,do_unit_tests,grounding_fraction, input_freq_distribution
+         old_bug_rotated_weights, make_calving_reproduce,restart_input_dir, orig_read, old_bug_bilin,do_unit_tests,grounding_fraction, &
+         input_freq_distribution, force_all_pes_traj, reverse_traj
 
 ! Local variables
 integer :: ierr, iunit, i, j, id_class, axes3d(3), is,ie,js,je,np
@@ -326,6 +331,7 @@ subroutine ice_bergs_framework_init(bergs, &
   bergs%clock_ior=mpp_clock_id( 'Icebergs-I/O read', flags=clock_flag_default, grain=CLOCK_SUBCOMPONENT )
   bergs%clock_iow=mpp_clock_id( 'Icebergs-I/O write', flags=clock_flag_default, grain=CLOCK_SUBCOMPONENT )
   bergs%clock_dia=mpp_clock_id( 'Icebergs-diagnostics', flags=clock_flag_default, grain=CLOCK_SUBCOMPONENT )
+
   call mpp_clock_begin(bergs%clock)
   call mpp_clock_begin(bergs%clock_ini)
 
@@ -1220,7 +1226,9 @@ subroutine unpack_traj_from_buffer2(first, buff, n)
     traj%cn=buff%data(22,n)
     traj%hi=buff%data(23,n)
 
-    call append_posn(first, traj) 
+!    call append_posn(first, traj) !This call could take a very long time (as if the run hangs) if there are millions of nodes in the list. Use push_posn instead and reverse the list later before writing the file.
+! 
+    call push_posn(first, traj) 
 
   end subroutine unpack_traj_from_buffer2
 
@@ -1642,6 +1650,30 @@ end subroutine record_posn
 
 ! ##############################################################################
 
+subroutine reverse_list(list)
+  ! Arguments
+  type(xyt), pointer :: list
+
+  ! Local variables
+  type(xyt), pointer :: head,tail,node
+  integer :: i
+
+  i=0
+  head=>list
+  tail=>list
+  node=>list%next
+  list%next=>null()
+  do while (associated(node))  
+     head=>node
+     node=>node%next
+     head%next=>tail
+     tail=>head
+     i=i+1
+  enddo
+  list=>head
+  print*,'reverse_list number of nodes= ',i
+end subroutine reverse_list
+
 subroutine push_posn(trajectory, posn_vals)
 ! Arguments
 type(xyt), pointer :: trajectory

icebergs_io.F90

@@ -16,20 +16,25 @@ module ice_bergs_io
 use fms_io_mod, only : register_restart_axis, register_restart_field, set_domain, nullify_domain
 use fms_io_mod, only : read_unlimited_axis =>read_compressed, field_exist, get_field_size
 
+use mpp_mod,    only : mpp_clock_begin, mpp_clock_end, mpp_clock_id
+use mpp_mod,    only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT, CLOCK_LOOP
+use fms_mod,    only : clock_flag_default
+
 use time_manager_mod, only: time_type, get_date, get_time, set_date, operator(-)
 
 use ice_bergs_framework, only: icebergs_gridded, xyt, iceberg, icebergs, buffer
 use ice_bergs_framework, only: pack_berg_into_buffer2,unpack_berg_from_buffer2
 use ice_bergs_framework, only: pack_traj_into_buffer2,unpack_traj_from_buffer2
 use ice_bergs_framework, only: find_cell,find_cell_by_search,count_bergs,is_point_in_cell,pos_within_cell,append_posn
+use ice_bergs_framework, only: push_posn
 use ice_bergs_framework, only: add_new_berg_to_list,destroy_iceberg
 use ice_bergs_framework, only: increase_ibuffer,increase_ibuffer_traj,grd_chksum2,grd_chksum3
 use ice_bergs_framework, only: sum_mass,sum_heat,bilin
 !params !Niki: write a subroutine to get these
 use ice_bergs_framework, only: nclasses, buffer_width, buffer_width_traj
 use ice_bergs_framework, only: verbose, really_debug, debug, restart_input_dir,make_calving_reproduce
 use ice_bergs_framework, only: ignore_ij_restart, use_slow_find,generate_test_icebergs,print_berg
-
+use ice_bergs_framework, only: reverse_list, force_all_pes_traj, reverse_traj
 
 implicit none ; private
 
@@ -48,6 +53,8 @@ module ice_bergs_io
 integer, allocatable,save :: io_tile_pelist(:)
 logical :: is_io_tile_root_pe = .true.
 
+integer :: clock_trw,clock_trp
+
 #ifdef _FILE_VERSION
   character(len=128) :: version = _FILE_VERSION
 #else
@@ -81,6 +88,9 @@ subroutine ice_bergs_io_init(bergs, io_layout)
      io_npes = io_layout(1)*io_layout(2)
   endif
 
+  clock_trw=mpp_clock_id( 'Icebergs-traj write', flags=clock_flag_default, grain=CLOCK_SUBCOMPONENT )
+  clock_trp=mpp_clock_id( 'Icebergs-traj prepare', flags=clock_flag_default, grain=CLOCK_SUBCOMPONENT )
+
 end subroutine ice_bergs_io_init
 
 ! ##############################################################################
@@ -842,19 +852,22 @@ subroutine write_trajectory(trajectory)
   ibuffer_io=>null()
 
   !Assemble the list of trajectories from all pes in this I/O tile
+  call mpp_clock_begin(clock_trp)
 
   !First add the trajs on the io_tile_root_pe (if any) to the I/O list
-  if(is_io_tile_root_pe) then
+  if(is_io_tile_root_pe .OR. force_all_pes_traj ) then
      if(associated(trajectory)) then
         this=>trajectory
         do while (associated(this))
-           call append_posn(traj4io, this)
+           call push_posn(traj4io, this)
            this=>this%next
         enddo
         trajectory => null()
      endif
   endif
 
+  if(.NOT. force_all_pes_traj ) then
+
   !Now gather and append the bergs from all pes in the io_tile to the list on corresponding io_tile_root_pe
   ntrajs_sent_io =0
   ntrajs_rcvd_io =0 
@@ -872,6 +885,7 @@ subroutine write_trajectory(trajectory)
            enddo
        endif
      enddo
+!     if(.NOT. reverse_traj .AND. associated(traj4io)) call reverse_list(traj4io)
   else
      ! Pack and send trajectories to the root PE for this I/O tile
      do while (associated(trajectory))
@@ -888,14 +902,25 @@ subroutine write_trajectory(trajectory)
      endif
   endif
 
+  endif !.NOT. force_all_pes_traj
+
+  !Here traj4io has all the trajectories in completely reverse order (last position of the last berg first)
+  !If a correct order is prefered in the trajectory file then reverse the linked list
+  !This may increase the the termination time of the model by a lot!!!
+  if(is_io_tile_root_pe .OR. force_all_pes_traj ) then
+    if(.NOT. reverse_traj .AND. associated(traj4io)) call reverse_list(traj4io)
+  endif
+
+  call mpp_clock_end(clock_trp)
 
 
   !Now start writing in the io_tile_root_pe if there are any bergs in the I/O list
+  call mpp_clock_begin(clock_trw)
 
-  if(is_io_tile_root_pe .AND. associated(traj4io)) then
+  if((force_all_pes_traj .OR. is_io_tile_root_pe) .AND. associated(traj4io)) then
 
   call get_instance_filename("iceberg_trajectories.nc", filename)
-    if(io_tile_id(1) .ge. 0) then !io_tile_root_pes write
+    if(io_tile_id(1) .ge. 0 .AND. .NOT. force_all_pes_traj) then !io_tile_root_pes write
        if(io_npes .gt. 1) then !attach tile_id  to filename only if there is more than one I/O pe
           if (io_tile_id(1)<10000) then
              write(filename,'(A,".",I4.4)') trim(filename), io_tile_id(1) 
@@ -1078,6 +1103,7 @@ subroutine write_trajectory(trajectory)
   if (iret .ne. NF_NOERR) write(stderrunit,*) 'diamonds, write_trajectory: nf_close failed',mpp_pe(),filename
 
   endif !(is_io_tile_root_pe .AND. associated(traj4io))
+  call mpp_clock_end(clock_trw)
 
 end subroutine write_trajectory