!--- cpp defs common to all files
#include "cpl_cppdefs"

program cpl_main
  !****************************************************************
  !--- Driver for the CCCma climate model coupler
  !---
  !--- Larry Solheim ...Jul,2014
  !****************************************************************

  use mpi
  use ccc_esmf
  use com_cpl
  use ccc_io
  use store
  use restart
  use history
  use field_ops
  use timer

  implicit none

  !--- The mpi communicator assigned to the coupler group
  integer(kind=impi) :: cpl_comm

  !--- Integer parameters passed to mpi routines
  integer(kind=impi) :: ierr, rank, nproc, mynode

  !--- ESMF return status
  integer(ESMF_KIND_I) :: rc_esmf

  !--- Varibles used to hold time information
  type(ESMF_Time) :: start_time, cpl_stop_time, curr_time, cpl_start_time, ref_time
  type(ESMF_Time) :: env_run_start_time, env_run_stop_time, atm_time
  type(ESMF_TimeInterval) :: sim_time

  !--- The minimum coupling interval
  type(ESMF_TimeInterval) :: time_step

  !--- The length of time the coupler (and atm,ocn,...) will run
  type(ESMF_TimeInterval) :: cpl_total_time
  integer(ESMF_KIND_I8) :: ocn_run_time_secs, atm_run_time_secs
  integer(ESMF_KIND_I4) :: cpl_run_time_secs

  !--- The coupler clock
  type(ESMF_Clock) :: cpl_clock

  !--- Keep track of the number of ringing alarms
  integer(ESMF_KIND_I4) :: ringing_alarm_count = 0

  !--- Return code from event handler
  integer :: evrc

  !--- misc
  integer(ESMF_KIND_I4) :: start_year, start_month, start_day
  integer(ESMF_KIND_I4) :: start_hour, start_minute, start_second
  integer(ESMF_KIND_I4) :: i4year, i4month, i4day
  integer(ESMF_KIND_I4) :: i4hour, i4minute, i4second
  integer(ESMF_KIND_I4) :: tmp_year, tmp_month, tmp_day
  integer :: ix, iy, iz, idx
  integer(ESMF_KIND_I4) :: cpl_step
  integer(ESMF_KIND_I8) :: xbuf(8)
  character(len=32) :: name=" ", time_string=" "
  character(len=256) :: strng = " "
  type(cpl_vinfo_t) :: cpl_vinfo
  logical :: trans, found, exists
  logical :: remote_atm_grid_desc = .false.
  logical :: remote_ocn_grid_desc = .false.
  logical :: remote_ice_grid_desc = .false.

  integer(kind=8), parameter :: sec_per_year = 31536000
  integer(kind=8), parameter :: sec_per_day  =    86400
  integer(kind=8), parameter :: sec_per_hour =     3600
  integer(kind=8), parameter :: sec_per_min  =       60
  integer(kind=8) :: secs
  integer :: ymd_hms(6)

  !--- number of days since Jan 1 0:0:0 to the start of each month
  integer(kind=8), dimension(12) :: som_day = &
      (/ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /)

  !--- number of days since Jan 1 0:0:0 to the end of each month
  integer(kind=8), dimension(12) :: eom_day = &
      (/ 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 /)

  !--- number of days in each month
  integer(kind=8), dimension(12) :: days_in_month = &
      (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)

  !--- Flag the write of certain debugging output to a file
  logical :: write_dbg_output = .false.
  integer, parameter :: iudbg = 494
  character(len=128) :: dbg_output_name = 'cpl_dbg_output'

  !--- Flag the write output to a file
  logical :: write_cpl_output = .false.

  !--- Integer flag to determine amount of diagnostic output to sdtout
  integer :: verbose=1

  !--- Work space used to hold logical records passed via MPI
  !--- and as the IO buffer for CCCma writes
  integer, parameter :: maxx=8392704  !---2049x4096
  real(ESMF_KIND_R8)    :: wrk(maxx), rbuf(8)
  integer(ESMF_KIND_I8) :: ibuf(8), idat(2*maxx)
  common /iocom/ ibuf,idat

  !--- Temporary wrk/ibuf arrays
  real(ESMF_KIND_R8)    :: tmp_wrk(maxx)
  integer(ESMF_KIND_I8) :: tmp_ibuf(8), tmp_idat(2*maxx)
  common /tmp_iocom/ tmp_ibuf,tmp_idat

  !--- Machine word size parameters (CCCma specific)
  integer :: machine, me32o64
  integer :: intsize, inteflt
  common /machtyp/ machine, intsize

  !===============================================================================
  !===============================================================================

  !--- Start MPI
  call mpi_init( ierr )

  !--- Initialize machine and intsize (required for CCCma io routines)
  machine = me32o64(idx)
  intsize = inteflt(idx)

  !--- Initialize total timer
  call wall_time("total")

  !--- Initialization timer
  call wall_time("start-up")

  !--- Initialize ...read namelists, etc
  call cpl_init()

  !--- Initialize groups for cpl, atm, ocn, ice, ...
  !--- This will, among other things, define cpl_master, atm_master, ocn_master
  !--- NOTE: cpl_master is the rank in MPI_COMM_WORLD not the rank in cpl_comm
  call define_group('cpl', cpl_comm)

  !--- Initialize the coupler event array and broadcast common variables
  !--- cpl_initialize_events will first call cpl_define_global_parameters to
  !--- broadcast values of certain atm and ocn variables to all mpi tasks
  !--- and then populate the global event array
  !--- e.g. atm_delt, atm_kstart, atm_ksteps, atm_kfinal, atm_kount
  !---      nemo_nn_ice, nemo_ncat, nemo_rn_rdt, nemo_nn_it000, nemo_nn_itend,
  !---      nemo_nn_date0, nemo_n_send_var, nemo_n_recv_var
  call cpl_initialize_events()

  !--- Determine rank and processor count in cpl_comm
  call mpi_comm_rank( cpl_comm, rank, ierr )
  call mpi_comm_size( cpl_comm, nproc, ierr )
  if (verbose > 2) then
    write(6,'(a,i12,3i8)')'=== cpl_main: cpl_comm, rank, size, cpl_master ', &
                       cpl_comm,rank,nproc,cpl_master
    call flush(6)
  endif

  !--- Determine the rank of this task in MPI_COMM_WORLD
  call mpi_comm_rank( MPI_COMM_WORLD, mynode, ierr )

  !--- cpl_PetCount is used in the ccc_esmf module
  cpl_PetCount = nproc
  if (verbose > 2) then
    write(6,'(a,4i8)')'=== cpl_main: cpl_PetCount = ',cpl_PetCount
  endif

  !--- Initialize ESMF
  !--- This must be done after MPI is initialized
  !--- Pass cpl_comm as a default integer to avoid type mismatches when
  !--- integer word size changes via compiler options
  idx = cpl_comm
  call init_esmf(idx, "cpl.Log")

  !--- Initialize ESMF grid objects
  call init_grids()

  !--- Write runtime grid information to disk (these files are saved with the restart)
  call create_atm_grid_file("cpl_atm_grid.nc")
  call create_ocn_grid_file("cpl_ocn_grid.nc")

  !--- Allocate and assign the global event array
  !--- This must be done after ESMF is initialized and grids are defined
  call define_events()

  !--- Define run start and stop times from year/month data
  !--- present in the namelist coupler_par
  if ( env_run_start_year > -1 .and. env_run_start_month > -1 ) then
    !--- Note that yy, mm, dd, h, m, s must be assigned integer*4 values in this call
    start_year  = env_run_start_year
    start_month = env_run_start_month
    start_day   = 1
    call ESMF_TimeSet(env_run_start_time, yy=start_year, mm=start_month, dd=start_day, rc=rc_esmf)
    call handle_ESMF_err(rc_esmf, "Problem setting env start time in coupler")
    if ( verbose > -1 ) then
      call ESMF_TimeGet(env_run_start_time, timeStringISOFrac=time_string)
      write(6,'(2a)')"=== cpl_main: env_run_start_time: ",trim(time_string)
    endif
  endif

  if ( env_run_stop_year > -1 .and. env_run_stop_month > -1 ) then
    !--- Note that yy, mm, dd, h, m, s must be assigned integer*4 values in this call
    start_year  = env_run_stop_year
    start_month = env_run_stop_month
    start_day   = days_in_month(env_run_stop_month)
    call ESMF_TimeSet(env_run_stop_time, yy=start_year, mm=start_month, dd=start_day, rc=rc_esmf)
    call handle_ESMF_err(rc_esmf, "Problem setting env stop time in coupler")
    if ( verbose > -1 ) then
      call ESMF_TimeGet(env_run_stop_time, timeStringISOFrac=time_string)
      write(6,'(2a)')"=== cpl_main:  env_run_stop_time: ",trim(time_string)
    endif
  endif

  if ( len_trim(env_start) > 0 ) write(6,'(2a)')"=== cpl_main: env_start = ",trim(env_start)
  if ( len_trim(env_model) > 0 ) write(6,'(2a)')"=== cpl_main: env_model = ",trim(env_model)

  !--- Define the atm and ocn run time in model seconds
  !--- NOTE: nemo_nn_itend is the last time step in the NEMO run whereas
  !---       atm_kfinal is the last time step plus 1 in the AGCM run
  if ( atm_kfinal <= atm_kount ) then
    write(6,'(a)')'=== cpl_main: kfinal is less that or equal to kount.'
    write(6,'(a,i12)')'   kount = ',atm_kount
    write(6,'(a,i12)')'  kfinal = ',atm_kfinal
    call xit("cpl_main",-1)
  endif
  atm_run_time_secs = (atm_kfinal-atm_kount)*atm_delt

#ifdef use_CanOM4
  !--- This will cause an error below ---FIXME---
  ocn_run_time_secs = -1
  !???? ocn_run_time_secs = atm_run_time_secs
#else
  if ( nemo_nn_itend < nemo_nn_it000 ) then
    write(6,'(a)')'=== cpl_main: nn_itend is less that nn_it000.'
    write(6,'(a,i12)')' nn_it000 = ',nemo_nn_it000
    write(6,'(a,i12)')' nn_itend = ',nemo_nn_itend
    call xit("cpl_main",-1)
  endif
  ocn_run_time_secs = (nemo_nn_itend - nemo_nn_it000 + 1) * nemo_rn_rdt
#endif
  if ( verbose > -5 ) then
    write(6,'(a,i10)')"=== cpl_main:    atm_kstart=",atm_kstart
    write(6,'(a,i10)')"=== cpl_main:    atm_ksteps=",atm_ksteps
    write(6,'(a,i10)')"=== cpl_main:     atm_kount=",atm_kount
    write(6,'(a,i10)')"=== cpl_main:    atm_kfinal=",atm_kfinal
    write(6,'(a,i10)')"=== cpl_main:      atm_delt=",atm_delt
    write(6,'(a,i12)')'=== cpl_main: nemo_nn_date0=',nemo_nn_date0
    write(6,'(a,i12)')'=== cpl_main: nemo_nn_it000=',nemo_nn_it000
    write(6,'(a,i12)')'=== cpl_main: nemo_nn_itend=',nemo_nn_itend
    write(6,'(a,i12)')'=== cpl_main:   nemo_rn_rdt=',nemo_rn_rdt
    write(6,'(a,i8,a)')"=== cpl_main: ATM run time is ",atm_run_time_secs," seconds."
    write(6,'(a,i8,a)')"=== cpl_main: OCN run time is ",ocn_run_time_secs," seconds."
    write(6,'(a,l1)')  '=== cpl_main:    atm_forcing_from_file=',atm_forcing_from_file
    write(6,'(a,i8)')  '=== cpl_main: specified_bc_year_offset=',specified_bc_year_offset
    call flush(6)
  endif

#ifdef use_NEMO
  if ( atm_run_time_secs /= ocn_run_time_secs ) then
    write(6,'(a)')'=== cpl_main: The ocean and the atmosphere have different run times.'
    write(6,'(a,i12,a)')'  ATM is set to run for ',atm_run_time_secs,' seconds'
    write(6,'(a,i12,a)')'  OCN is set to run for ',ocn_run_time_secs,' seconds'
    call xit("cpl_main",-1)
  endif
#endif

  if ( atm_run_time_secs < 1 ) then
    write(6,'(a,i12)')'=== cpl_main: Invalid total run time ',atm_run_time_secs
    call xit("cpl_main",-1)
  endif

  !--- Define the total run time as an ESMF interval variable
  cpl_run_time_secs = atm_run_time_secs
  call ESMF_TimeIntervalSet(cpl_total_time, ESMF_CALKIND_NOLEAP, s=cpl_run_time_secs, rc=rc_esmf)
  call handle_ESMF_err(rc_esmf, "Problem setting CPL run time")

  !--- Set the start_time for this invocation
  !--- The value of secs is seconds since 1-1-1 0:0:0 in the following
  secs = atm_kount*atm_delt + sec_per_year
  call secs2ymd(secs, ymd_hms)
  start_year  = ymd_hms(1)
  start_month = ymd_hms(2)
  start_day   = ymd_hms(3)
  start_hour  = ymd_hms(4)
  start_minute= ymd_hms(5)
  start_second= ymd_hms(6)
  !--- Note that yy, mm, dd, h, m, s must be assigned integer*4 values in this call
  call ESMF_TimeSet(start_time, yy=start_year, mm=start_month, dd=start_day, &
                                h=start_hour, m=start_minute, s=start_second, rc=rc_esmf)
  call handle_ESMF_err(rc_esmf, "Problem setting start time in coupler")

  !--- Set the coupler reference time for this invocation
  ref_time = start_time

  !--- Set the coupler start time for this invocation
  cpl_start_time = start_time

  !--- Initialize the string cpl_time_string (found in com_cpl) with the coupler starting time
  !--- and brodacast this value to all tasks
  call ESMF_TimeGet(cpl_start_time, timeStringISOFrac=cpl_time_string)
  do idx=1,len_trim(cpl_time_string)
    if ( cpl_time_string(idx:idx) .eq. "T" ) cpl_time_string(idx:idx) = " "
  enddo
  call bcastGroup(cpl_time_string, cpl_master, MPI_COMM_WORLD)

  !--- Set the coupler stop time for this invocation
  cpl_stop_time = start_time + cpl_total_time

  !--- cpl_step is the coupler time step interval (in seconds)
  !--- This must be done after all events are defined (after the call to define_events)
  !--- since the coupling frequency of every event is required
  cpl_step = get_cpl_step(idx)
  if ( idx /= 0 ) then
    write(6,*)'=== cpl_main: Problem determining the coupler time step.'
    call xit("cpl_main",-1)
  endif
  write(6,'(a,i8,a)')"=== cpl_main: Coupler time step is ",cpl_step," seconds"
  call flush(6)

  !--- Assign this to a variable that is available to any routine that uses com_cpl
  cpl_time_step_secs = cpl_step
  cpl_time_step_iter = 0

  !--- Define the coupler time step interval as an ESMF interval variable
  call ESMF_TimeIntervalSet(time_step, ESMF_CALKIND_NOLEAP, s=cpl_step, rc=rc_esmf)
  call handle_ESMF_err(rc_esmf, "Problem setting minimum coupling interval in coupler")

  !--- Reset start time to be 1 coupler time step interval before the desired start time
  !--- This will allow the coupler clock to be incremented at the top of the time loop
  !--- Note that the alarm start time is not changed
  start_time = start_time - time_step

  !--- Assign the coupler start time in seconds
  !--- cpl_start_time_secs is found in com_cpl
  call ESMF_TimeGet(start_time, s_i8=cpl_start_time_secs)

  !--- Create the coupler clock
  cpl_clock = ESMF_ClockCreate(time_step, startTime=start_time, stopTime=cpl_stop_time, &
                               refTime=ref_time, name="Coupler Clock", rc=rc_esmf)
  call handle_ESMF_err(rc_esmf, "Problem creating coupler clock")

  call ESMF_TimeGet(cpl_start_time, timeStringISOFrac=time_string)
  write(6,'(2a)')"=== cpl_main: cpl_start_time: ",trim(time_string)
  call ESMF_TimeGet(cpl_stop_time, timeStringISOFrac=time_string)
  write(6,'(2a)')"=== cpl_main:  cpl_stop_time: ",trim(time_string)
  call flush(6)

  !--- Allocate and assign the global alarm array and assign alarms to events
  call set_alarms(cpl_clock, cpl_start_time)

  !--- Initialize ringing_alarm_count
  ringing_alarm_count = 0

  !--- Read the current time from the coupler clock
  time_string = get_time_string(cpl_clock)

  if ( len_trim(cpl_rs_file_name_in) < 1 ) then
    write(6,*)'cpl_main: Input restart file name is blank.'
    call xit("cpl_main",-2)
  endif

  !--- Ensure that the coupler restart file exists then read it
  inquire( file=trim(cpl_rs_file_name_in), exist=exists )
  if ( exists ) then
    write(6,*)'cpl_main: : ',trim(cpl_rs_file_name_in)," exists"
    call flush(6)
  else
    write(6,*)'cpl_main: : ',trim(cpl_rs_file_name_in)," does not exist"
    call flush(6)
  endif
  if ( .not. exists .and. &
       env_run_start_year == start_year .and. env_run_start_month == start_month ) then
    !--- If a coupler restart file does not exist then attempt to create one in certain cases
    !--- Do this only at the start of a run
    if ( cpl_use_initial_conditions .or. atm_forcing_from_file ) then
      !--- If there is no restart file then create one filled with initial conditions
      write(6,'(3a)')"=== cpl_main: Restart file ",trim(cpl_rs_file_name_in), &
          " does not exist. Creating a new coupler restart file."
      call restart_write(trim(cpl_rs_file_name_in), time_string, initial=.true.)
    else
      write(6,'(3a)')"=== cpl_main: Coupler restart file ",trim(cpl_rs_file_name_in)," is missing."
      call xit("cpl_main",-3)
    endif
  endif
  call restart_read(cpl_rs_file_name_in, time_string)
  write(6,*)'cpl_main: Time stamp found in restart file: ',trim(time_string)
  call flush(6)

  !--- Get the current time on the clock
  call ESMF_ClockGet(cpl_clock, currTime=curr_time, rc=rc_esmf)
  call handle_ESMF_err(rc_esmf, "cpl_main: Problem reading initial time.")

  !--- Write variables read from the coupler restart to the history file
  cpl_elapsed_time_secs = 0
  call history_write(cpl_hist_file_name, cpl_clock)

#undef DBGbfb
#ifdef DBGbfb
strng = " "
if ( len_trim(env_runid) > 0 ) then
  strng = trim(cpl_rs_file_name_out)//"_"//trim(env_runid)//"_after_initial_read"
else
  strng = trim(cpl_rs_file_name_out)//"_after_initial_read"
endif
call restart_write(strng, time_string)
#endif

  call wall_time("start-up")

  !--- Loop over time
  TIME_LOOP: do while ( .true. )

    !--- Only the master node should do anything below this line in TIME_LOOP
    !??? if ( mynode /= cpl_master ) cycle TIME_LOOP

    !--- Keep track of the current iteration of this loop
    cpl_time_step_iter = cpl_time_step_iter + 1


    call wall_time("cpl time step", reset=.true.)

    !--- Advance the coupler clock
    call ESMF_ClockAdvance(cpl_clock, ringingAlarmCount=ringing_alarm_count, rc=rc_esmf)
    call handle_ESMF_err(rc_esmf, "Problem advancing time on coupler clock")

    !--- Get the current time on the clock
    call ESMF_ClockGet(cpl_clock, currTime=curr_time, rc=rc_esmf)
    call handle_ESMF_err(rc_esmf, "cpl_main: Problem reading time.")

    !--- Assign the string cpl_time_string (found in com_cpl) with the current coupler time
    call ESMF_TimeGet(curr_time, timeStringISOFrac=cpl_time_string)
    do idx=1,len_trim(cpl_time_string)
      if ( cpl_time_string(idx:idx) .eq. "T" ) cpl_time_string(idx:idx) = " "
    enddo

    !--- Assign the number of elasped seconds at the current coupler time
    !--- This will be seconds since 1 coupling interval before the start of month and therefore
    !--- will represent the end of the coupling interval (which corresponds with what the AGCM
    !--- thinks the time is when it sends fields back to the coupler)
    !--- cpl_elapsed_time_secs is found in com_cpl
    call ESMF_TimeGet(curr_time, s_i8=cpl_elapsed_time_secs)
    cpl_elapsed_time_secs = cpl_elapsed_time_secs - cpl_start_time_secs

    !--- Assign year and day of the year at the current coupler time
    call ESMF_TimeGet(curr_time, yy=cpl_year, dayOfYear=cpl_day_of_year)
    write(6,'(a,i3,4(a,i12))')"=== cpl_main: iter=",cpl_time_step_iter, &
                              " cpl_start_time_secs=",cpl_start_time_secs, &
                              " cpl_elapsed_time_secs=",cpl_elapsed_time_secs, &
                              " cpl_year=", cpl_year, &
                              " cpl_day_of_year=",cpl_day_of_year

    !--- Write current time info to stdout
    write(6,'(a,i4,3a,i10)')"=== cpl_main: iter=",cpl_time_step_iter, &
                            " current time: ",trim(cpl_time_string), &
                            " elasped time (seconds): ",cpl_elapsed_time_secs
    call flush(6)

    if ( ESMF_ClockIsStopTime(cpl_clock) ) then
      !--- This is the last time step
      !--- Send a message to the atm telling it to stop
      xbuf(:) = 0
      ibuf(1) = transfer("GRID", 1_8)
      ibuf(2) = 0
      ibuf(3) = transfer(" MSG", 1_8)
      ibuf(4) = 1
      ibuf(5) = 8
      ibuf(6) = 1
      ibuf(7) = 0
      ibuf(8) = 1
      write(6,*)"=== cpl_main: Stop Time: xbuf = ",xbuf(1:8)
      call flush(6)
      call send_data_rec(xbuf, ibuf, atm_master, "MSG", dbg=1)

      !--- Exit the time loop
      exit TIME_LOOP
    endif

    call wall_time("process alarms", reset=.true.)
    !--- Process any ringing alarms
    if (ringing_alarm_count > 0) then
#ifdef DBGbfb
call ESMF_TimeGet(curr_time, timeStringISOFrac=time_string)
strng = " "
if ( len_trim(env_runid) > 0 ) then
  strng = trim(cpl_rs_file_name_out)//"_"//trim(env_runid)//"_1_"//trim(time_string)
else
  strng = trim(cpl_rs_file_name_out)//"_1_"//trim(time_string)
endif
call restart_write(strng, time_string)
#endif
      do idx=1,nevents
        if ( ESMF_AlarmIsRinging( alarm(event(idx)%alarm_index), rc=rc_esmf) ) then
          !--- Take any action required by this alarm
          call execute_event(idx, cpl_clock, evrc)

          !--- Turn alarm off after processing
          call ESMF_AlarmRingerOff( alarm(event(idx)%alarm_index), rc=rc_esmf)

          !--- Process the return code from execute_event
          if ( evrc /= 0 ) then
            !--- A return code of 1 means a normal exit
            if ( evrc == 1 ) exit TIME_LOOP

            !--- Any other non-zero value is an error
            write(6,*)"=== cpl_main: Error in event handler ",evrc
            call xit("cpl_main",-90)
          endif
        endif
      enddo
#ifdef DBGbfb
call ESMF_TimeGet(curr_time, timeStringISOFrac=time_string)
strng = " "
if ( len_trim(env_runid) > 0 ) then
  strng = trim(cpl_rs_file_name_out)//"_"//trim(env_runid)//"_2_"//trim(time_string)
else
  strng = trim(cpl_rs_file_name_out)//"_2_"//trim(time_string)
endif
call restart_write(strng, time_string)
#endif
    endif
    call wall_time("process alarms", verbose=0)

    !--- Note: atm_kount2 is sent from the AGCM after it has integrated for 1 coupling time step,
    !--- written to the gs file and sent flux fields back to the coupler. This means that the AGCM
    !--- is at the end of its coupling cycle and therefore the value of atm_kount2 reflects this.
    !--- The value of secs is seconds since 1-1-1 0:0:0 in the following to be consistent with
    !--- the meaning of KOUNT in the AGCM
    secs = atm_kount2*atm_delt + sec_per_year
    call secs2ymd(secs, ymd_hms)
    i4year  = ymd_hms(1)
    i4month = ymd_hms(2)
    i4day   = ymd_hms(3)
    i4hour  = ymd_hms(4)
    i4minute= ymd_hms(5)
    i4second= ymd_hms(6)
    !--- Note that yy, mm, dd, h, m, s must be assigned integer*4 values in this call
    call ESMF_TimeSet(atm_time, yy=i4year, mm=i4month, dd=i4day, &
                                 h=i4hour, m=i4minute, s=i4second, rc=rc_esmf)
    call handle_ESMF_err(rc_esmf, "Problem setting atm time in coupler")

    call ESMF_TimeGet(atm_time, timeStringISOFrac=time_string)
    call FilterTS(time_string)

    write(6,'(a,i4,4a,a,i10)') &
        "=== cpl_main: iter=",cpl_time_step_iter, &
        " coupler time: ",trim(cpl_time_string), &
        "     atm time: ",trim(time_string), &
        "  atm_kount =",atm_kount2

    if ( write_cpl_output ) then
       call wall_time("write history", reset=.true.)
       call history_write(cpl_hist_file_name, cpl_clock)
       call wall_time("write history", verbose=0)
       call wall_time("cpl time step", verbose=0)
    endif

  enddo TIME_LOOP

  !--- Read the current time from the coupler clock
  time_string = get_time_string(cpl_clock)

  !--- Write the coupler restart file
  call restart_write(cpl_rs_file_name_out, time_string)

  !--- Get the elapsed wall time
  call wall_time("total", verbose=0)

  !--- Print timer stats
  call wall_time_stats(save_to_datapath=.false., verbose=1)

  if (verbose > 0) then
    write(6,'(a,i3,a)')'=== cpl_main: Coupler on node ',mynode,' is DONE.'
    call flush(6)
  endif

  !--- Stop MPI
  call mpi_finalize( ierr )

!---FIXME---
!--- The following call to ESMF_Finalize results in a segfault
!--- Not sure it is even necessary (could be for closing log files) since the code runs
!--- without this call so simply comment it out for now. Possibly get back to it later.
  !--- Stop ESMF
  !--- ESMF_Finalize must be called after the call to mpi_finalize since it will call
  !--- mpi_finalize if MPI is still active. If ESMF calls mpi_finalize then it will
  !--- only stop a subset of tasks as it is only aware of the coupler comm world.
!  call ESMF_Finalize( endflag=ESMF_END_KEEPMPI, rc=rc_esmf )
!  call handle_ESMF_err(rc_esmf, "cpl_main: Problem in ESMF_Finalize.")

contains

  subroutine print_timeInterval(interval)
    type(ESMF_TimeInterval), intent(in) :: interval
    character(32) :: strng
    integer :: i, l
    strng = " "
    call ESMF_TimeIntervalGet(interval, timeStringISOFrac=strng)
    l = 0
    do i=1,len(strng)
      select case(strng(i:i))
        case("P")
          l = 1
          strng(i:i) = " "
        case("Y")
          strng(i:i) = "-"
        case("M")
          if ( l==1 ) strng(i:i) = "-"
          if ( l==2 ) strng(i:i) = ":"
        case("D")
          strng(i:i) = " "
        case("T")
          l = 2
          strng(i:i) = " "
        case("H")
          strng(i:i) = ":"
        case("S")
          strng(i:i) = " "
      end select
    enddo
    write(6,'(a)')trim(strng)
  end subroutine print_timeInterval

  function FilterTimeString(strng) result(filtered)
    character(*), intent(in) :: strng

    !--- Local
    character(64) :: filtered
    integer :: i

    filtered = " "
    filtered = trim(strng)
    do i=1,len_trim(filtered)
      select case(filtered(i:i))
        case("P")
          filtered(i:i) = " "
      end select
    enddo

  end function FilterTimeString

  subroutine FilterTS(strng)
    character(*) :: strng

    !--- Local
    integer :: idx

    do idx=1,len_trim(strng)
      if ( strng(idx:idx) .eq. "T" ) strng(idx:idx) = " "
    enddo

  end subroutine FilterTS

  recursive function gcd_rec(p,q) result(gcd)
    !--- Determine the greatest common divisor of 2 positive integers
    integer :: gcd
    integer, intent(in) :: p,q
 
    if (mod(p,q) /= 0) then
        gcd = gcd_rec(q, modulo(p,q))
    else
        gcd = q
    end if
  end function gcd_rec

  function get_cpl_step(rc) result(step)
    !--- Get the coupler time step in seconds
    !--- The coupler time step should satisfy the following constraints
    !---   1) It is no greater than the smallest coupling interval used by
    !---      any component model involved in the coupling process
    !---   2) The coupling intervals of all component models must be an
    !---      integer multiple of the coupler time step

    !--- A return status (rc == 0 means success)
    integer :: rc

    !--- Return the coupler time step in seconds
    integer :: step

    !--- Local
    integer :: idx1, idx2
    integer, allocatable :: all_freq(:)
    logical :: found

    rc = 0

    !--- Coupler events must be defined prior to calling this routine
    if ( nevents <= 0 ) then
      write(6,*)"get_cpl_step: The events array is not defined."
      call xit("get_cpl_step",-1)
    endif

    !--- Put the coupling frequency in seconds for every field transferred
    !--- by the coupler into a local array named all_freq
    allocate( all_freq(nevents) )
    do idx1=1,nevents
      all_freq(idx1) = event(idx1) % freq
    enddo

    if (verbose > 10) then
      write(6,*)'get_cpl_step: all_freq = ',all_freq(:)
    endif

    !--- This satisfies the first constraint
    step = minval( all_freq )

    if (verbose > 10) then
      write(6,*)'get_cpl_step: Smallest coupling interval is ',step
    endif

    found = .false.
    idx2 = 0
    do while (.not. found)
      idx2 = idx2 + 1
      if ( idx2 > 1000 ) then
        !--- Guard against potential runaway edge cases
        rc = 1
        exit
      endif

      !--- Modify step for values that do not satisfy the second constraint
      do idx1=1,nevents
        if ( modulo(all_freq(idx1),step) /= 0 ) then
          step = gcd_rec(all_freq(idx1), step)
        endif
      enddo

      if (verbose > 10) then
        write(6,*)'get_cpl_step: iteration ',idx2,'  step = ',step
      endif

      !--- If we satisfy the second constraint for all coupling intervals
      !--- then exit the loop, otherwise continue iterating to modify step
      found = .true.
      do idx1=1,nevents
        if ( modulo(all_freq(idx1),step) /= 0 ) found = .false.
      enddo
    enddo

    deallocate( all_freq )

  end function get_cpl_step

  subroutine cpl_init()
    !--- Initialize the coupler
    !--- Read namelist, process grid description files, etc
    implicit none

    !--- Read the coupler_par namelist file.
    !--- The coupler_par namelist is defined in com_cpl
    !--- This must be done prior to the call to define_group
    !--- The coupler_par namelist file name is hard coded to be "nl_coupler_par"
    !--- Should this be changed so that the user supplies the name???
    inquire(file='nl_coupler_par', exist=found)
    if ( .not. found ) then
      write(6,'(a)')'=== cpl_main: Namelist file nl_coupler_par is missing.'
      call flush(6)
      call xit("cpl_init",-1)
    endif
    open(95,file='nl_coupler_par',form='formatted')
    read(95,coupler_par)
    close(95)

    !--- Do not use atm_grid_desc or ocn_grid_desc files
    !--- Reading these files may be required again in the future but for now
    !--- overwrite them with blanks so that they will not be used
    atm_grid_desc = " "
    ocn_grid_desc = " "
    ice_grid_desc = " "
    canom4_grid_desc = " "

    if ( verbose > -10 ) write(6,coupler_par)

  end subroutine cpl_init

  subroutine execute_event(event_id, clock, evrc)
    !--- Do what needs to be done for this event
    implicit none

    !--- The event array index
    integer :: event_id

    !--- The coupler clock
    type(ESMF_Clock) :: clock

    !--- An integer return code (0 == success, 1 == DONE)
    integer :: evrc

    integer(ESMF_KIND_I)  :: rc
    character(32) :: time_string
    character(32) :: get_name, put_name
    character(32) :: get_model, put_model
    logical :: trans
    integer(kind=impi) :: get_master, put_master
    integer(ESMF_KIND_I8) :: xbuf(8)
    integer :: idx1, idx2
    integer :: regrid_id, ncopy
    logical :: is_msg
    integer :: verbose=1

    evrc = 0

    !--- Set parameters that are determined from the event array
    get_name   = trim(adjustl(event(event_id)%get_var))
    put_name   = trim(adjustl(event(event_id)%put_var))
    get_model  = event(event_id)%get_model
    put_model  = event(event_id)%put_model
    get_master = event(event_id)%get_master
    put_master = event(event_id)%put_master
    regrid_id  = event(event_id)%regrid_id
    ncopy      = event(event_id)%ncopy
    is_msg     = event(event_id)%is_msg

    if ( verbose > 1 ) then
      time_string = get_time_string(cpl_clock)
      write(6,'(a,i3,5a,i3)') "cpl_event ",event_id," at ",trim(time_string), &
        " :: ",trim(event(event_id)%action),'  copies = ',ncopy
      call flush(6)
    endif

    !--- Process and return if this event is a special op
    if ( special_ops(event_id) ) return

    if ( atm_forcing_from_file ) then
      !--- Do not transfer any fields destined for the ocean
      !--- These fields will exist but are only meant to be written
      !--- to the coupler history file
      if ( trim(adjustl(get_model)) .eq. "cpl" .and. &
           trim(adjustl(put_model)) .eq. "ocn" ) then
        return
      endif
    endif

    !--- Set a timer for this event
    call wall_time(trim(event(event_id)%action), reset=.true.)

    !--- Perform the transfer operation ncopy times
    do idx1=1,ncopy
      if ( is_msg ) then
        !--- This is a message transfer
        if ( verbose > 10 ) then
          write(6,'(a,i3,a,i3,5a,3(i3,a))')"cpl_event ",event_id," copy ",idx1, &
            "  transfer_data(",trim(get_name),", ",trim(put_name),", ", &
            get_master,", ", put_master,", ",regrid_id,", xbuf)"
          call flush(6)
        endif
        !--- For the time being use the name "MSG" for all message transfers
        !--- This is because the tag associated with MSG is hard coded into
        !--- the CanOM4 ocean and the agcm. The transfer will hang if the coupler
        !--- does not use this tag with its own mpi_send and mpi_recv
        !--- calls ("MSG" is associated with tag=900)
        !--- This implies that get_name is not necessarily "MSG"
        !---
        !--- Return a copy of the message buffer in xbuf
        xbuf(:) = 1
        trans = transfer_data("MSG", "MSG", get_master, put_master, &
                              regrid_id, xbuf=xbuf)
        select case ( trim(get_name) )
          case ('MSG_ocn')
            !--- This is a message from the ocean to the atm
            !--- xbuf(1) = 1 means continue, otherwise stop
            !--- xbuf(2) = coupler year
            !--- xbuf(3) = coupler day of the year   (1-365)
            !--- xbuf(4) = coupler second of the day (0-86399)

            if ( xbuf(1) /= 1 ) then
              !--- This is the signal from the ocean that it has finished
              !--- and when the atm gets this signal it will also stop
              !--- Therefore the coupler should stop
              !--- This needs to be rethought at some point but we stick with
              !--- the status quo for now
              write(6,'(a)')'execute_event: OCN signals DONE.'
              call flush(6)
              !--- Tell the main program to exit TIME_LOOP
              evrc = 1
            endif

          case ('MSG_atm')
            !--- This is a message from the atm to the ocean
            !--- xbuf(1) = day of year
            !--- xbuf(2) = number of days since start of simulation (NDAYS)
            !--- xbuf(3) = present month (MONTH)
            !--- xbuf(4) = set to DONE if AGCM is at the end of a month
            !--- xbuf(5) = timestep (KSTART)
            !--- xbuf(6) = DELT
            !--- xbuf(7) = KOUNT
            write(6,'(a,8i12)')"execute_event: xbuf=",xbuf(1:8)
            call flush(6)
            if ( transfer(xbuf(4),"XXXX") .eq. "DONE" ) then
              write(6,'(a)')'execute_event: ATM signals DONE.'
            endif
            call flush(6)

          case ('MSG', 'MSG_ice')
            !--- These are valid message names

          case default
            write(6,'(2a)')'execute_event: ** WW ** Unknown message type ',trim(get_name)
            call flush(6)

        end select

      else

        !--- This is a normal data transfer
        if ( verbose > 10 ) then
          write(6,'(a,i3,5a,3(i3,a))')"execute_event: ",idx1, &
            " transfer_data(",trim(get_name),", ",trim(put_name),", ", &
            get_master,", ", put_master,", ",regrid_id,")"
          call flush(6)
        endif
        trans = transfer_data(trim(get_name), trim(put_name), get_master, put_master, &
                              regrid_id)

      endif
    enddo

    !--- Assign a time for this event
    call wall_time(trim(event(event_id)%action), verbose=0)
                                
    call flush(6)

  end subroutine execute_event

  function transfer_data(get_name, put_name, get_master, put_master, &
                         regrid_id, xbuf, dbg) result(success)
    implicit none

    !--- The return value is logical indicating whether or not transfer succeeded
    logical :: success

    !--- This is the name of the field that is received from get_master
    character(len=*), intent(in)   :: get_name

    !--- This is the name of the field that is sent to put_master
    character(len=*), intent(in)   :: put_name

    !--- get_master is the rank of the master task from which the data is received
    integer(kind=impi), intent(in) :: get_master

    !--- put_master is the rank of the master task to which the data is sent
    integer(kind=impi), intent(in) :: put_master

    !--- An integer flag to identify the type of regridding required (if any)
    integer, intent(in) :: regrid_id

    !--- The message buffer that was transferred will be returned to the caller
    integer(kind=8), intent(out), optional :: xbuf(:)

    !--- Debug level passed to (send|recv)_data_rec
    integer, intent(in), optional :: dbg

    !--- Local
    integer :: verbose=1
    character(len=32)  :: local_put_name
    integer :: ldbg, nwrds, gid, iu, nan_count
    type(cpl_vinfo_t) :: get_vinfo, put_vinfo
    logical :: is_msg, exists
#undef DBG_bfb
#ifdef DBG_bfb
    logical :: dump_send_and_recv_fields = .true.
#else
    logical :: dump_send_and_recv_fields = .false.
#endif
    integer(kind=8) :: cpl_freq
    character(len=32) :: get_prog, put_prog
    character(len=4) :: vname
    real (kind=8) :: curr_avg
    real (kind=8), pointer :: data_ptr(:) => null()
    integer(kind=8), pointer :: ibuf_ptr(:) => null()
    success = .true.

    !--- Obtain information about the current variable
    !--- Note find_cpl_vinfo will abort if get_name is not valid
    get_vinfo = find_cpl_vinfo( name=trim(adjustl(get_name)) )
    put_vinfo = find_cpl_vinfo( name=trim(adjustl(put_name)) )

    !--- Go ahead with the transfer
    if ( present(dbg) ) then
      ldbg = dbg
    else
      ldbg = 1
    endif

    local_put_name = " "
    local_put_name = trim(put_name)

    !--- Do basic verification of input parameters and assign program names
    !--- for sending and receiving programs (used for diagnostic output only)
    get_prog = " "
    if ( get_master == cpl_master ) then
      get_prog = "CPL"
    else if ( get_master == atm_master ) then
      get_prog = "ATM"
    else if ( get_master == ocn_master ) then
      get_prog = "OCN"
    else if ( get_master == ice_master ) then
      get_prog = "ICE"
    else
      write(6,'(a,i8)')'transfer_data: Invalid get_master = ',get_master
      call flush(6)
      call xit("transfer_data",-1)
    endif

    put_prog = " "
    if ( put_master == cpl_master ) then
      put_prog = "CPL"
    else if ( put_master == atm_master ) then
      put_prog = "ATM"
    else if ( put_master == ocn_master ) then
      put_prog = "OCN"
    else if ( put_master == ice_master ) then
      put_prog = "ICE"
    else
      write(6,'(a,i8)')'transfer_data: Invalid put_master = ',put_master
      call flush(6)
      call xit("transfer_data",-2)
    endif

    if ( get_master == put_master ) then
      write(6,'(2a)')'transfer_data: Send and receive is from the same program ',trim(get_prog)
      call flush(6)
      call xit("transfer_data",-3)
    endif

    if ( verbose > 10 ) then
      write(6,'(2a,2x,a,i8)')'transfer_data: get_name,put_name,freq ', &
                         trim(get_name), trim(put_name), get_vinfo%freq
      call flush(6)
    endif

    !--- Determine whether or not the current transfer is a "msg" transfer
    is_msg = .false.
    if ( trim(adjustl(get_vinfo%grid)) .eq. "msg" ) is_msg = .true.

    if ( is_msg ) then
      !--- Handle MSG records separately from other records
      !--- Pass the message along unmodified but keep a copy of
      !--- the message in the coupler (in xbuf)

      if ( .not. present(xbuf) ) then
        write(6,'(a)')'transfer_data: xbuf is required for MSG records.'
        call flush(6)
        call xit("transfer_data",-4)
      endif

      if ( get_master == cpl_master ) then
        !--- Assign xbuf and ibuf from data stored internal to the coupler
        if ( .true.) then
          !--- Hard code the message here for now
          ibuf(1) = transfer("GRID", 1_8)
          ibuf(2) = 0
          ibuf(3) = transfer(" MSG", 1_8)
          ibuf(4) = 1
          ibuf(5) = 8
          ibuf(6) = 1
          ibuf(7) = 0
          ibuf(8) = 1
          rbuf(:) = 1
          !--- and append it to storage
          call store_appendRecord(put_name, msg_gid, rbuf, ibuf)
        endif
        nwrds = store_readRecord(put_name, msg_gid, data_ptr, ibuf_ptr, idx=-1)
        !--- Retain a maximum of 2 records in the MSG list
        call store_ShiftRecord(put_name, msg_gid, max_size=2)
        call store_listRecord(put_name, msg_gid)
        if ( nwrds <= 1 ) then
          write(6,'(3a)')'transfer_data: Unable to read ',trim(put_name),' from storage.'
          call xit("transfer_data",-5)
        endif
        xbuf(1:nwrds) = data_ptr(1:nwrds)
        deallocate(data_ptr)
        ibuf(1:8) = ibuf_ptr(1:8)
        deallocate(ibuf_ptr)
        if ( verbose > 10 ) then
          write(6,'(4a)')"transfer_data: Read ",trim(put_name)," from storage: ", &
            trim(format_ibuf(ibuf))
          call flush(6)
        endif
      else
        !--- Receive MSG as an integer array (xbuf) from get_master
        call recv_data_rec(xbuf, ibuf, get_master, trim(get_name), dbg=ldbg)
        if ( get_master == atm_master ) then
          !--- This is a message from the atm
          !--- xbuf(1) = day of year
          !--- xbuf(2) = number of days since start of simulation (NDAYS)
          !--- xbuf(3) = present month (MONTH)
          !--- xbuf(4) = set to DONE if AGCM is at the end of a month
          !--- xbuf(5) = timestep (KSTART)
          !--- xbuf(6) = DELT
          !--- xbuf(7) = KOUNT
          !--- atm_kstartc and atm_kount2 are defined in com_cpl
          atm_kstartc = xbuf(5)
          atm_kount2  = xbuf(7)
          write(6,'(a,8i12)')"transfer_data: xbuf=",xbuf(1:8)
          call flush(6)
          if ( transfer(xbuf(4),"XXXX") .eq. "DONE" ) then
            write(6,'(a)')'transfer_data: ATM signals DONE.'
          endif
          call flush(6)
        endif
      endif

      if ( ldbg > 0 ) then
        write(6,'(5a,$)') '=== cpl_main: ',trim(get_name),' from ',trim(get_prog),' = '
        write(6,'(8i12)')xbuf(1:8)
        call flush(6)
      endif

      if ( put_master == cpl_master ) then
        !--- Store xbuf and ibuf in coupler memory or on disk
        if ( verbose > 10 ) then
          write(6,'(2a)')"transfer_data: call store_appendRecord(name, xbuf, ibuf)  ibuf: ", &
              trim(format_ibuf(ibuf))
          call flush(6)
        endif
        rbuf(:) = xbuf(:)
        call store_appendRecord(put_name, msg_gid, rbuf, ibuf)
        !--- Retain a maximum of 2 records in the MSG list
        call store_ShiftRecord(put_name, msg_gid, max_size=2)
        call store_listRecord(put_name, msg_gid)
      else
        !--- Send MSG as an integer array (xbuf) to put_master
        if ( verbose > 10 ) then
          write(6,'(2a,2x,3a)')"transfer_data: send to ", &
              trim(put_prog),trim(put_name),": ",trim(format_ibuf(ibuf))
          call flush(6)
        endif
        call send_data_rec(xbuf, ibuf, put_master, trim(put_name), dbg=ldbg)
      endif

    else

      if ( get_master == cpl_master ) then
        !--- Coupler sends data

        !--- Define the group ID for this variable
        if ( put_master == ocn_master ) then
          !--- coupler sends data to the ocean, assume this data is from the agcm
          gid = atm_gid
        else if ( put_master == atm_master ) then
          !--- coupler sends data to the agcm, assume this data is from the ocean
          gid = ocn_gid
        else
          write(6,*)"transfer_data: Invalid put_master for reading ",trim(put_name)
          call xit("transfer_data",-6)
        endif
        !--- Reset the group ID for certain variables
        gid = filter_group_ID(put_name, gid)

        !--- Assign wrk and ibuf from data stored internal to the coupler
        nwrds = store_readRecord(put_name, gid, data_ptr, ibuf_ptr, idx=-1)
        if ( nwrds <= 1 ) then
          write(6,'(3a)')'transfer_data: Unable to read ',trim(put_name),' from storage.'
          call xit("transfer_data",-6)
        endif
        wrk(1:nwrds) = data_ptr(1:nwrds)
        deallocate(data_ptr)
        ibuf(1:8) = ibuf_ptr(1:8)
        deallocate(ibuf_ptr)
        if ( verbose > 10 ) then
          write(6,'(4a)')"transfer_data: Read ",trim(put_name)," from storage: ", &
            trim(format_ibuf(ibuf))
          call flush(6)
        endif
      else
        !--- Receive data from the program associated with get_master
        if ( verbose > 10 ) then
          write(6,'(4a)')"transfer_data: Receiving ",trim(get_name)," from ",trim(get_prog)
          call flush(6)
        endif
        call recv_data_rec(wrk, ibuf, get_master, trim(get_name), dbg=ldbg)

        if ( dump_send_and_recv_fields ) then
          !--- Dump the field to a disk file immediately after recieving (use for debugging)
          strng = " "
          write(strng,'(3a)')trim(get_name),"_recv_from_",trim(get_prog)
          nwrds = put_vinfo%size
          call dump_farray(trim(strng),wrk(1:nwrds),idx=cpl_elapsed_time_secs)
        endif

        nwrds = put_vinfo%size
        nan_count = count( wrk(1:nwrds) /= wrk(1:nwrds) )
        if ( nan_count > 0 ) then
          write(6,*)"transfer_data: CPL receiving ",trim(get_name)," from ",trim(get_prog), &
                    "  found ",nan_count," Nans"
          call flush(6)
          call xit("transfer_data",-90)
        endif

      endif

      if ( ibuf(3) < 10000 ) then
        !--- Assume that the sending program has written a non-character value
        !--- in ibuf3 (e.g. the atm will do this in some cases)
        !--- Insert the first 4 chars of the variable name as determined from
        !--- the coupler name in get_name
        ibuf(3) = transfer(get_vinfo%ccc_name(1:4), 1_8)
      endif

      if ( write_dbg_output ) then
        !--- Always force a packing density of 1
        ibuf(8) = 1
        open(iudbg,file=trim(dbg_output_name),form='unformatted',position='append')
        write(6,'(4a)')'Write to ',trim(dbg_output_name),': ',trim(format_ibuf(ibuf))
        call putfld2(iudbg,wrk,ibuf,maxx)
        close(iudbg)
      endif

      if ( regrid_id > 0 ) then
        !--- This field needs to be interpolated before being passed along
        write(6,'(3a,i3)')'transfer_data: ',trim(get_name),' regrid_id = ',regrid_id
        write(6,'(2a)')'transfer_data: regrid ibuf in  ',trim(format_ibuf(ibuf))

!dbg use tmp arrays and reset put_name until this is working
        tmp_wrk = wrk
        tmp_ibuf = ibuf
        local_put_name = get_name
!dbg use tmp arrays and reset put_name until this is working

        if ( .true. ) then
          open(iudbg,file=trim(dbg_output_name),form='unformatted',position='append')
          write(6,'(4a)')'Write to ',trim(dbg_output_name),': ',trim(format_ibuf(ibuf))
          tmp_ibuf(8) = 1
          call putfld2(iudbg,tmp_wrk,tmp_ibuf,maxx)
          close(iudbg)
        endif

        call regrid_field(regrid_id, get_vinfo%olap, put_vinfo%olap, tmp_wrk)
        tmp_ibuf(5) = put_vinfo%nlon + put_vinfo%olap
        tmp_ibuf(6) = put_vinfo%nlat
        write(6,'(2a)')'transfer_data: regrid ibuf out ',trim( format_ibuf(tmp_ibuf) )

        if ( .true. ) then
          open(iudbg,file=trim(dbg_output_name),form='unformatted',position='append')
          write(vname,'(i4.4)')regrid_id
          tmp_ibuf(3) = transfer(vname(1:4),1)
          tmp_ibuf(8) = 1
          write(6,'(4a)')'Write to ',trim(dbg_output_name),': ',trim(format_ibuf(tmp_ibuf))
          call putfld2(iudbg,tmp_wrk,tmp_ibuf,maxx)
          close(iudbg)
        endif

      else
        if ( trim(adjustl(get_name)) .ne. trim(adjustl(put_name)) ) then
          write(6,'(a)')"transfer_data: ** WW ** No regrid done but get_name and put_name differ."
          write(6,'(2a)')"transfer_data: ** WW ** get_name is ",trim(get_name)
          write(6,'(2a)')"transfer_data: ** WW ** put_name is ",trim(put_name)
          call flush(6)
          !xxx call xit("transfer_data",-3)
        endif
      endif

      !--- NOTE: If regrid_field was called above then it will have redefined the wrk array
      if ( put_master == cpl_master ) then
        !--- Coupler receives data
        !--- Define the group ID for this variable
        if ( get_master == ocn_master ) then
          !--- Coupler receives data from the ocean
          gid = ocn_gid
        else if ( get_master == atm_master ) then
          !--- Coupler receives data from the agcm
          gid = atm_gid
        else
          write(6,*)"transfer_data: Invalid get_master for reading ",trim(local_put_name)
          call xit("transfer_data",-6)
        endif
        !--- Reset the group ID for certain variables
        gid = filter_group_ID(local_put_name, gid)
        if ( verbose > 10 ) then
          write(6,'(2a)')"transfer_data: call store_appendRecord(name, wrk, ibuf)  ibuf: ", &
              trim(format_ibuf(ibuf))
          call flush(6)
        endif
        !--- Store wrk and ibuf in coupler memory or on disk
        call store_appendRecord(local_put_name, gid, wrk, ibuf)
        call store_listRecord(local_put_name, gid)

      else
        !--- Send data to the program associated with put_master
        if ( verbose > 10 ) then
          write(6,'(2a,2x,3a)')"transfer_data: send to ", &
              trim(put_prog),trim(local_put_name),": ",trim(format_ibuf(ibuf))
          call flush(6)
        endif

        if ( dump_send_and_recv_fields ) then
          !--- Dump the field to a disk file immediately before sending (use for debugging)
          strng = " "
          write(strng,'(3a)')trim(local_put_name),"_sent_to_",trim(put_prog)
          nwrds = put_vinfo%size
          call dump_farray(trim(strng),wrk(1:nwrds),idx=cpl_elapsed_time_secs)
        endif

        nwrds = put_vinfo%size
        nan_count = count( wrk(1:nwrds) /= wrk(1:nwrds) )
        if ( nan_count > 0 ) then
          write(6,*)"transfer_data: CPL sending ",trim(local_put_name)," to ",trim(put_prog), &
                    "  found ",nan_count," Nans"
          call flush(6)
          call xit("transfer_data",-91)
        endif

        call send_data_rec(wrk, ibuf, put_master, trim(local_put_name), dbg=ldbg)
      endif
    endif

    if ( verbose > 10 ) then
      write(6,'(3a,i8)')'transfer_data: Transferred ', &
                         trim(local_put_name),"  freq=",get_vinfo%freq
      call flush(6)
    endif

  end function transfer_data

  subroutine secs2ymd(secs, ymd_hms)
    !--- Determine year, mon, day, hour, min, sec from total seconds
    !--- assuming a 365 day calander

    integer(kind=8) :: secs
    integer :: ymd_hms(6)

    !--- Local
    integer(kind=8), parameter :: sec_per_year = 31536000
    integer(kind=8), parameter :: sec_per_day  =    86400
    integer(kind=8), parameter :: sec_per_hour =     3600
    integer(kind=8), parameter :: sec_per_min  =       60
    integer(kind=8), parameter :: one = 1

    integer(kind=8) :: dt, doy, part_secs
    integer(kind=8) :: year, mon, day, hour, min, sec
    integer :: idx
    integer :: verbose = 0

    !--- number of days since Jan 1 0:0:0 to the start of each month
    integer(kind=8), save, dimension(12) :: som_day = &
      (/ 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 /)

    !--- number of days since Jan 1 0:0:0 to the end of each month
    integer(kind=8), save, dimension(12) :: eom_day = &
      (/ 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334, 365 /)

    year = secs/sec_per_year

    !--- Set part_secs to the number of seconds in the last partial year
    part_secs = mod(secs, sec_per_year)

    !--- current day of the year, as int
    doy = one + part_secs/sec_per_day

    mon=0
    do idx=1,12
      if (doy.le.eom_day(idx)) then
        mon=idx
        exit
      endif
    enddo
    if (mon.lt.1 .or. mon.gt.12) then
      write(6,'(a)')'secs2ymd: Unable to determine month.'
      call xit("secs2ymd",-1)
    endif

    !--- Determine day of the current month as int
    day = doy - som_day(mon)

    !--- Set dt to the number of seconds in the last partial day
    !--- and the determine partial H,M,S for this day
    dt = mod(part_secs, sec_per_day)
    hour = dt/sec_per_hour
    min  = (dt - hour*sec_per_hour)/sec_per_min
    sec  = dt - hour*sec_per_hour - min*sec_per_min

    !--- Assign the output array
    ymd_hms(1) = year
    ymd_hms(2) = mon
    ymd_hms(3) = day
    ymd_hms(4) = hour
    ymd_hms(5) = min
    ymd_hms(6) = sec

    if (verbose > 1) then
      write(6,'(a,i14,a,i4,5(a,i2.2))') "secs2ymd:  secs=",secs, &
        "   ",year,"-",mon,"-",day," ",hour,":",min,":",sec
    endif
  end subroutine secs2ymd

end program cpl_main
