module ocn_comp_mct 2,44
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||
!BOP
! !MODULE: ocn_comp_mct
! !INTERFACE:
! !DESCRIPTION:
! This is the main driver for the Parallel Ocean Program (POP).
!
! !REVISION HISTORY:
! SVN:$Id:
!
! !USES:
use POP_KindsMod
use POP_ErrorMod
use POP_CommMod
use POP_FieldMod
use POP_GridHorzMod
use POP_HaloMod
use POP_IOUnitsMod
use POP_MCT_vars_mod
use mct_mod
use esmf_mod
use seq_flds_mod
use seq_flds_indices
use seq_cdata_mod
use seq_infodata_mod
use seq_timemgr_mod
use shr_file_mod
use shr_cal_mod, only : shr_cal_date2ymd
use shr_sys_mod
use perf_mod
use ocn_communicator, only: mpi_communicator_ocn
use kinds_mod, only: int_kind, r8
use POP_KindsMod
use POP_ErrorMod
use POP_InitMod, only: POP_Initialize1, POP_Initialize2, &
timer_total, cpl_ts
use communicate, only: my_task, master_task
use constants
use blocks
use domain, only: distrb_clinic, POP_haloClinic
use exit_mod
use forcing_shf, only: SHF_QSW
use forcing_sfwf, only: lsend_precip_fact, precip_fact
use forcing_fields
use forcing_coupled, only: ncouple_per_day, &
update_ghost_cells_coupler_fluxes, &
rotate_wind_stress, pop_set_coupled_forcing, &
pop_init_coupled, &
orb_eccen, orb_obliqr, orb_lambm0, orb_mvelpp
use ice, only: tfreez, tmelt, liceform,QFLUX, QICE, AQICE, &
tlast_ice
use grid, only: TLAT, TLON, KMT
use global_reductions, only: global_sum_prod
use io_tools, only: document
use named_field_mod, only: named_field_register, named_field_get_index, &
named_field_set, named_field_get
use prognostic
use timers, only: get_timer, timer_start, timer_stop
use diagnostics, only: check_KE
use output, only: output_driver
use step_mod, only: step
use time_management
use registry
!
! !PUBLIC MEMBER FUNCTIONS:
implicit none
public :: ocn_init_mct
public :: ocn_run_mct
public :: ocn_final_mct
SAVE
private ! By default make data private
!
! ! PUBLIC DATA:
!
! !REVISION HISTORY:
! Author: Mariana Vertenstein
!
!EOP
! !PRIVATE MODULE FUNCTIONS:
private :: ocn_export_mct
private :: ocn_import_mct
private :: ocn_SetGSMap_mct
private :: ocn_domain_mct
!
! !PRIVATE MODULE VARIABLES
logical (log_kind) :: &
ldiag_cpl = .false.
integer (int_kind), private :: &
cpl_write_restart, &! flag id for write restart
cpl_write_history, &! flag id for write history
cpl_write_tavg, &! flag id for write tavg
cpl_diag_global, &! flag id for computing diagnostics
cpl_diag_transp ! flag id for computing diagnostics
real (r8), &
dimension(:,:,:,:), allocatable :: &
SBUFF_SUM ! accumulated sum of send buffer quantities
! for averaging before being sent
real (r8) :: &
tlast_coupled
integer (int_kind) :: &
nsend, nrecv
character(char_len) :: &
runtype
type(seq_infodata_type), pointer :: &
infodata
!=======================================================================
contains
!***********************************************************************
!BOP
!
! !IROUTINE: ocn_init_mct
!
! !INTERFACE:
subroutine ocn_init_mct( EClock, cdata_o, x2o_o, o2x_o, NLFilename ) 1,54
!
! !DESCRIPTION:
! Initialize POP
!
! !INPUT/OUTPUT PARAMETERS:
type(ESMF_Clock) , intent(in) :: EClock
type(seq_cdata) , intent(inout) :: cdata_o
type(mct_aVect) , intent(inout) :: x2o_o, o2x_o
character(len=*), optional , intent(in) :: NLFilename ! Namelist filename
!
! !REVISION HISTORY:
! Author: Mariana Vertenstein
!EOP
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer(int_kind) :: &
OCNID, &
mpicom_o, &
lsize, &
start_ymd, &
start_tod, &
start_year, &
start_day, &
start_month, &
start_hour, &
iyear, &
ocn_cpl_dt, &
pop_cpl_dt, &
shrlogunit, & ! old values
shrloglev ! old values
type(mct_gsMap), pointer :: &
gsMap_o
type(mct_gGrid), pointer :: &
dom_o
integer (POP_i4) :: &
errorCode ! error code
integer (int_kind) :: &
nThreads
real (r8) :: &
precadj
integer (int_kind) :: iam,ierr
character(len=32) :: starttype ! infodata start type
#ifdef _OPENMP
integer, external :: omp_get_max_threads ! max number of threads that can execute
! concurrently in a single parallel region
#endif
integer :: lbnum
!-----------------------------------------------------------------------
!
! set cdata pointers
!
!-----------------------------------------------------------------------
errorCode = POP_Success
#ifdef _OPENMP
nThreads = omp_get_max_threads()
#endif
call seq_cdata_setptrs(cdata_o, ID=OCNID, mpicom=mpicom_o, &
gsMap=gsMap_o, dom=dom_o, infodata=infodata)
POP_MCT_OCNID = OCNID
POP_MCT_gsMap_o => gsMap_o
POP_MCT_dom_o => dom_o
#if (defined _MEMTRACE)
call MPI_comm_rank(mpicom_o,iam,ierr)
if(iam == 0) then
lbnum=1
call memmon_dump_fort('memmon.out','ocn_init_mct:start::',lbnum)
endif
#endif
! The following communicator module variable will be utilize in init_communicate that
! is called by initial - this is done to make the code backwards compatible
mpi_communicator_ocn = mpicom_o
!-----------------------------------------------------------------------
!
! initialize the model run
!
!-----------------------------------------------------------------------
call seq_infodata_GetData( infodata, case_name=runid )
call seq_infodata_GetData( infodata, start_type=starttype)
if ( trim(starttype) == trim(seq_infodata_start_type_start)) then
runtype = "initial"
else if (trim(starttype) == trim(seq_infodata_start_type_cont) ) then
runtype = "continue"
else if (trim(starttype) == trim(seq_infodata_start_type_brnch)) then
runtype = "branch"
else
write(stdout,*) 'ocn_comp_mct ERROR: unknown starttype'
call exit_POP(sigAbort,' ocn_comp_mct ERROR: unknown starttype')
end if
!TODO: check for consistency of pop runid and runtype with seq_infodata
!-----------------------------------------------------------------------
!
! first initializaiton phase of pop2
! initialize pop2 because grid information is needed for
! creation of GSMap_ocn.
! call pop initialization routines in two stages (needed for backwards
! compatiblity with cpl6 concurrent system
!
!-----------------------------------------------------------------------
call t_startf ('pop_init')
call POP_Initialize1(errorCode)
!-----------------------------------------------------------------------
!
! register non-standard incoming fields
!
!-----------------------------------------------------------------------
if (index_x2o_Sa_co2prog > 0) then
call named_field_register('ATM_CO2_PROG', ATM_CO2_PROG_nf_ind)
endif
if (index_x2o_Sa_co2diag > 0) then
call named_field_register('ATM_CO2_DIAG', ATM_CO2_DIAG_nf_ind)
endif
call register_string('pop_init_coupled')
call flushm (stdout)
!-----------------------------------------------------------------------
!
! second initialization phase of pop2
!
!-----------------------------------------------------------------------
call POP_Initialize2(errorCode)
!-----------------------------------------------------------------------
!
! initialize time-stamp information
!
!-----------------------------------------------------------------------
call ccsm_char_date_and_time
call t_stopf ('pop_init')
!----------------------------------------------------------------------------
!
! reset shr logging to my log file
!
!----------------------------------------------------------------------------
call shr_file_getLogUnit (shrlogunit)
call shr_file_getLogLevel(shrloglev)
call shr_file_setLogUnit (stdout)
!-----------------------------------------------------------------------
!
! check for consistency of pop and sync clock initial time
!
!-----------------------------------------------------------------------
if (runtype == 'initial') then
call seq_timemgr_EClockGetData(EClock, &
start_ymd=start_ymd, start_tod=start_tod)
call shr_cal_date2ymd(start_ymd,start_year,start_month,start_day)
if (iyear0 /= start_year) then
if(master_task == my_task) then
call document ('ocn_init_mct', 'iyear0 ', iyear0)
call document ('ocn_init_mct', 'start_year ', start_year)
endif
call exit_POP(sigAbort,' iyear0 does not match start_year')
end if
if (imonth0 /= start_month) then
if(master_task == my_task) then
call document ('ocn_init_mct', 'imonth0 ', imonth0)
call document ('ocn_init_mct', 'start_month ', start_month)
endif
call exit_POP(sigAbort,' imonth0 does not match start_year')
end if
if (iday0 /= start_day) then
if(master_task == my_task) then
call document ('ocn_init_mct', 'iday0 ', iday0)
call document ('ocn_init_mct', 'start_day ', start_day)
endif
end if
#ifndef _HIRES
if (seconds_this_day /= start_tod) then
call document ('ocn_init_mct', 'sec0 ', seconds_this_day)
call document ('ocn_init_mct', 'start_tod ', start_tod)
call exit_POP(sigAbort,' sec0 does not start_tod')
end if
#endif
end if
!-----------------------------------------------------------------------
!
! initialize MCT attribute vectors and indices
!
!-----------------------------------------------------------------------
call t_startf ('pop_mct_init')
call ocn_SetGSMap_mct( mpicom_o, OCNID, GSMap_o )
lsize = mct_gsMap_lsize(gsMap_o, mpicom_o)
! Initialize mct ocn domain (needs ocn initialization info)
call ocn_domain_mct( lsize, gsMap_o, dom_o )
! Inialize mct attribute vectors
call mct_aVect_init(x2o_o, rList=seq_flds_x2o_fields, lsize=lsize)
call mct_aVect_zero(x2o_o)
call mct_aVect_init(o2x_o, rList=seq_flds_o2x_fields, lsize=lsize)
call mct_aVect_zero(o2x_o)
nsend = mct_avect_nRattr(o2x_o)
nrecv = mct_avect_nRattr(x2o_o)
allocate (SBUFF_SUM(nx_block,ny_block,max_blocks_clinic,nsend))
!-----------------------------------------------------------------------
!
! Initialize flags and shortwave absorption profile
! Note that these cpl_write_xxx flags have no freqency options
! set; therefore, they will retain a default value of .false.
! unless they are explicitly set .true. at the appropriate times
!
!-----------------------------------------------------------------------
call init_time_flag('cpl_write_restart',cpl_write_restart, owner = 'ocn_init_mct')
call init_time_flag('cpl_write_history',cpl_write_history, owner = 'ocn_init_mct')
call init_time_flag('cpl_write_tavg' ,cpl_write_tavg, owner = 'ocn_init_mct')
call init_time_flag('cpl_diag_global' ,cpl_diag_global, owner = 'ocn_init_mct')
call init_time_flag('cpl_diag_transp' ,cpl_diag_transp, owner = 'ocn_init_mct')
lsmft_avail = .true.
tlast_coupled = c0
!-----------------------------------------------------------------------
!
! initialize necessary coupling info
!
!-----------------------------------------------------------------------
call seq_timemgr_EClockGetData(EClock, dtime=ocn_cpl_dt)
pop_cpl_dt = seconds_in_day / ncouple_per_day
if (pop_cpl_dt /= ocn_cpl_dt) then
write(stdout,*)'pop_cpl_dt= ',pop_cpl_dt, &
' ocn_cpl_dt= ',ocn_cpl_dt
call exit_POP(sigAbort,'ERROR pop_cpl_dt and ocn_cpl_dt must be identical')
end if
!-----------------------------------------------------------------------
!
! send intial state to driver
!
!-----------------------------------------------------------------------
if ( lsend_precip_fact ) then
precadj = precip_fact * 1.0e6_r8
call seq_infodata_PutData( infodata, precip_fact=precadj)
end if
call pop_sum_buffer
call ocn_export_mct(o2x_o, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorPrint(errorCode)
call exit_POP(sigAbort, 'ERROR in ocn_export_mct')
endif
call t_stopf ('pop_mct_init')
call seq_infodata_PutData( infodata, &
ocn_nx = nx_global , ocn_ny = ny_global)
call seq_infodata_PutData( infodata, &
ocn_prognostic=.true., ocnrof_prognostic=.true.)
!----------------------------------------------------------------------------
!
! Reset shr logging to original values
!
!----------------------------------------------------------------------------
call shr_file_setLogUnit (shrlogunit)
call shr_file_setLogLevel(shrloglev)
#if (defined _MEMTRACE)
if(iam == 0) then
! write(6,*) 'ocn_init_mct:end::'
lbnum=1
call memmon_dump_fort('memmon.out','ocn_init_mct:end::',lbnum)
call memmon_reset_addr()
endif
#endif
!-----------------------------------------------------------------------
!
! document orbital parameters
!
!-----------------------------------------------------------------------
if (registry_match('qsw_distrb_iopt_cosz')) then
call seq_infodata_GetData(infodata, &
orb_eccen=orb_eccen, orb_mvelpp=orb_mvelpp, orb_lambm0=orb_lambm0, orb_obliqr=orb_obliqr)
write(stdout,*) ' '
call document ('ocn_import_mct', 'orb_eccen ', orb_eccen)
call document ('ocn_import_mct', 'orb_mvelpp ', orb_mvelpp)
call document ('ocn_import_mct', 'orb_lambm0 ', orb_lambm0)
call document ('ocn_import_mct', 'orb_obliqr ', orb_obliqr)
endif
!-----------------------------------------------------------------------
!
! Now document all time flags, because this is the last step of pop2
! initialization
!
!-----------------------------------------------------------------------
call document_time_flags
!-----------------------------------------------------------------------
!
! output delimiter to log file
!
!-----------------------------------------------------------------------
if (my_task == master_task) then
write(stdout,blank_fmt)
write(stdout,'(" End of initialization")')
write(stdout,blank_fmt)
write(stdout,ndelim_fmt)
call POP_IOUnitsFlush(POP_stdout)
#ifdef CCSMCOUPLED
call POP_IOUnitsFlush(stdout)
#endif
endif
!-----------------------------------------------------------------------
!EOC
end subroutine ocn_init_mct
!***********************************************************************
!BOP
!
! !IROUTINE: ocn_run_mct
!
! !INTERFACE:
subroutine ocn_run_mct( EClock, cdata_o, x2o_o, o2x_o) 1,33
!
! !DESCRIPTION:
! Run POP for a coupling interval
!
! !INPUT/OUTPUT PARAMETERS:
type(ESMF_Clock) , intent(in) :: EClock
type(seq_cdata) , intent(inout) :: cdata_o
type(mct_aVect) , intent(inout) :: x2o_o
type(mct_aVect) , intent(inout) :: o2x_o
!
! !REVISION HISTORY:
! Author: Mariana Vertenstein
!EOP
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer(int_kind) :: &
errorCode ! error flag
integer(int_kind) :: &
ymd, & ! POP2 current date (YYYYMMDD)
tod, & ! POP2 current time of day (sec)
ymd_sync, & ! Sync clock current date (YYYYMMDD)
tod_sync, & ! Sync clcok current time of day (sec)
shrlogunit, & ! old values
shrloglev ! old values
character(len=char_len_long) :: &
fname
character(len=*), parameter :: &
SubName = "ocn_run_mct"
type(seq_infodata_type), pointer :: &
infodata ! Input init object
real (r8) :: &
precadj
logical :: &
lcoupled, & ! temporary
rstwr, & ! true => write restart at end of day
first_time = .true.
character (char_len) :: message
integer(int_kind) :: info_debug
integer :: lbnum
#if (defined _MEMTRACE)
if(my_task == 0 ) then
lbnum=1
call memmon_dump_fort('memmon.out',SubName//':start::',lbnum)
endif
#endif
!-----------------------------------------------------------------------
!
! start up the main timer
!
!-----------------------------------------------------------------------
call timer_start(timer_total)
!-----------------------------------------------------------------------
!
! reset shr logging to my log file
!
!----------------------------------------------------------------------------
errorCode = POP_Success
call shr_file_getLogUnit (shrlogunit)
call shr_file_getLogLevel(shrloglev)
call shr_file_setLogUnit (stdout)
call seq_cdata_setptrs(cdata_o, infodata=infodata)
!----------------------------------------------------------------------------
!
! restart flag (rstwr) will assume only an eod restart for now
!
!----------------------------------------------------------------------------
call seq_infodata_GetData( infodata, info_debug=info_debug)
if (info_debug >= 2) then
ldiag_cpl = .true.
else
ldiag_cpl = .false.
endif
rstwr = seq_timemgr_RestartAlarmIsOn(EClock)
if (rstwr) then
call override_time_flag(cpl_write_restart,value=.true.)
call ccsm_char_date_and_time ! set time_management module vars cyear, cmonth, ..
write(message,'(6a)') 'driver requests restart file at eod ', &
cyear,'/',cmonth,'/',cday
call document ('ocn_comp_mct(run):', message)
endif
!-----------------------------------------------------------------------
!
! advance the model in time over coupling interval
! write restart dumps and archiving
!
!-----------------------------------------------------------------------
! Note that all ocean time flags are evaluated each timestep in time_manager
! ocn_import_mct is analogous to pop_unpack_fluxes_from_coupler in cpl6
! ocn_export_mct is analogous to prepare_send_to_coupler in cpl6
! tlast_coupled is set to zero at the end of ocn_export_mct
advance: do
! obtain import state from driver
if (check_time_flag(cpl_ts) .or. nsteps_run == 0) then
call ocn_import_mct(x2o_o, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorPrint(errorCode)
call exit_POP(sigAbort, 'ERROR in step')
endif
call pop_set_coupled_forcing
end if
call step(errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorPrint(errorCode)
call exit_POP(sigAbort, 'ERROR in step')
endif
if (check_KE(100.0_r8)) then
!*** exit if energy is blowing
call output_driver
call exit_POP(sigAbort,'ERROR: k.e. > 100 ')
endif
call output_driver
! return export state to driver
call pop_sum_buffer()
if (check_time_flag(cpl_ts)) then
call ocn_export_mct(o2x_o, errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorPrint(errorCode)
call exit_POP(sigAbort, 'ERROR in ocn_export_mct')
endif
exit advance
end if
enddo advance
if ( lsend_precip_fact ) then
precadj = precip_fact * 1.0e6_r8
call seq_infodata_PutData( infodata, precip_fact=precadj )
end if
!--------------------------------------------------------------------
!
! check that internal clock is in sync with master clock
!
!--------------------------------------------------------------------
ymd = iyear*10000 + imonth*100 + iday
tod = ihour*seconds_in_hour + iminute*seconds_in_minute + isecond
if ( .not. seq_timemgr_EClockDateInSync( EClock, ymd, tod ) )then
call seq_timemgr_EClockGetData( EClock, curr_ymd=ymd_sync, &
curr_tod=tod_sync )
write(stdout,*)' pop2 ymd=',ymd ,' pop2 tod= ',tod
write(stdout,*)' sync ymd=',ymd_sync,' sync tod= ',tod_sync
write(stdout,*)' Internal pop2 clock not in sync with Sync Clock'
call shr_sys_abort( SubName// &
":: Internal pop2 clock not in sync with Sync Clock")
end if
!----------------------------------------------------------------------------
!
! Reset shr logging to original values
!
!----------------------------------------------------------------------------
call shr_file_setLogUnit (shrlogunit)
call shr_file_setLogLevel(shrloglev)
call timer_stop(timer_total)
#if (defined _MEMTRACE)
if(my_task == 0) then
lbnum=1
call memmon_dump_fort('memmon.out',SubName//':end::',lbnum)
call memmon_reset_addr()
endif
#endif
!-----------------------------------------------------------------------
!EOC
end subroutine ocn_run_mct
!***********************************************************************
!BOP
!
! !IROUTINE: ocn_final_mct
!
! !INTERFACE:
subroutine ocn_final_mct( ) 1,2
!
! !DESCRIPTION:
! Finalize POP
!
! !USES:
use POP_FinalMod
!
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (POP_i4) :: &
errorCode ! error code
!-----------------------------------------------------------------------
call POP_Final(errorCode)
end subroutine ocn_final_mct
!***********************************************************************
!BOP
!IROUTINE: ocn_SetGSMap_mct
! !INTERFACE:
subroutine ocn_SetGSMap_mct( mpicom_ocn, OCNID, gsMap_ocn ) 1,2
! !DESCRIPTION:
! This routine mct global seg maps for the pop decomposition
!
! !REVISION HISTORY:
! same as module
! !INPUT/OUTPUT PARAMETERS:
implicit none
integer , intent(in) :: mpicom_ocn
integer , intent(in) :: OCNID
type(mct_gsMap), intent(inout) :: gsMap_ocn
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer,allocatable :: &
gindex(:)
integer (int_kind) :: &
i,j, k, n, iblock, &
lsize, gsize, &
ier
type (block) :: &
this_block ! block information for current block
!-----------------------------------------------------------------------
! Build the POP grid numbering for MCT
! NOTE: Numbering scheme is: West to East and South to North starting
! at the south pole. Should be the same as what's used in SCRIP
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n=n+1
enddo
enddo
enddo
lsize = n
! not correct for padding, use "n" above
! lsize = block_size_x*block_size_y*nblocks_clinic
gsize = nx_global*ny_global
allocate(gindex(lsize),stat=ier)
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n=n+1
gindex(n) = (this_block%j_glob(j)-1)*(nx_global) + this_block%i_glob(i)
enddo
enddo
enddo
call mct_gsMap_init( gsMap_ocn, gindex, mpicom_ocn, OCNID, lsize, gsize )
deallocate(gindex)
!-----------------------------------------------------------------------
!EOC
end subroutine ocn_SetGSMap_mct
!***********************************************************************
!BOP
! !IROUTINE: ocn_domain_mct
! !INTERFACE:
subroutine ocn_domain_mct( lsize, gsMap_o, dom_o ) 1,4
! !DESCRIPTION:
! This routine mct global seg maps for the pop decomposition
!
! !REVISION HISTORY:
! same as module
!
! !INPUT/OUTPUT PARAMETERS:
implicit none
integer , intent(in) :: lsize
type(mct_gsMap), intent(in) :: gsMap_o
type(mct_ggrid), intent(inout) :: dom_o
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer, pointer :: &
idata(:)
real(r8), pointer :: &
data(:)
integer (int_kind) :: &
i,j, k, n, iblock, &
ier
type (block) :: &
this_block ! block information for current block
!-------------------------------------------------------------------
!
! initialize mct domain type, lat/lon in degrees,
! area in radians^2, mask is 1 (ocean), 0 (non-ocean)
!
!-------------------------------------------------------------------
call mct_gGrid_init( GGrid=dom_o, CoordChars=trim(seq_flds_dom_coord), &
OtherChars=trim(seq_flds_dom_other), lsize=lsize )
call mct_aVect_zero(dom_o%data)
allocate(data(lsize))
!-------------------------------------------------------------------
!
! Determine global gridpoint number attribute, GlobGridNum, which is set automatically by MCT
!
!-------------------------------------------------------------------
call mct_gsMap_orderedPoints(gsMap_o, my_task, idata)
call mct_gGrid_importIAttr(dom_o,'GlobGridNum',idata,lsize)
!-------------------------------------------------------------------
!
! Determine domain (numbering scheme is: West to East and South to North to South pole)
! Initialize attribute vector with special value
!
!-------------------------------------------------------------------
data(:) = -9999.0_R8
call mct_gGrid_importRAttr(dom_o,"lat" ,data,lsize)
call mct_gGrid_importRAttr(dom_o,"lon" ,data,lsize)
call mct_gGrid_importRAttr(dom_o,"area" ,data,lsize)
call mct_gGrid_importRAttr(dom_o,"aream",data,lsize)
data(:) = 0.0_R8
call mct_gGrid_importRAttr(dom_o,"mask",data,lsize)
call mct_gGrid_importRAttr(dom_o,"frac",data,lsize)
!-------------------------------------------------------------------
!
! Fill in correct values for domain components
!
!-------------------------------------------------------------------
n=0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n=n+1
data(n) = TLON(i,j,iblock)*radian
enddo
enddo
enddo
call mct_gGrid_importRattr(dom_o,"lon",data,lsize)
n=0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n=n+1
data(n) = TLAT(i,j,iblock)*radian
enddo
enddo
enddo
call mct_gGrid_importRattr(dom_o,"lat",data,lsize)
n=0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n=n+1
data(n) = TAREA(i,j,iblock)/(radius*radius)
enddo
enddo
enddo
call mct_gGrid_importRattr(dom_o,"area",data,lsize)
n=0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n=n+1
data(n) = float(KMT(i,j,iblock))
if (data(n) > 1.0_r8) data(n) = 1.0_r8
enddo
enddo
enddo
call mct_gGrid_importRattr(dom_o,"mask",data,lsize)
call mct_gGrid_importRattr(dom_o,"frac",data,lsize)
deallocate(data)
deallocate(idata)
!-----------------------------------------------------------------------
!EOC
end subroutine ocn_domain_mct
!***********************************************************************
!BOP
! !IROUTINE: ocn_import_mct
! !INTERFACE:
subroutine ocn_import_mct(x2o_o, errorCode) 1,19
! !DESCRIPTION:
! This routine receives message from cpl7 driver
!
! !REVISION HISTORY:
! same as module
! !INPUT/OUTPUT PARAMETERS:
type(mct_aVect) , intent(inout) :: x2o_o
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
character (char_len) :: &
label, &
message
integer (int_kind) :: &
i,j,k,n,iblock
real (r8), dimension(nx_block,ny_block) :: &
WORKB
real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: &
WORK1, WORK2 ! local work space
real (r8) :: &
m2percm2, &
gsum
type (block) :: this_block ! local block info
!-----------------------------------------------------------------------
!
! zero out padded cells
!
!-----------------------------------------------------------------------
errorCode = POP_Success
WORK1 = c0
WORK2 = c0
!-----------------------------------------------------------------------
!
! unpack and distribute wind stress, then convert to correct units
! and rotate components to local coordinates
!
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
WORK1(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_taux,n)
WORK2(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_tauy,n)
enddo
enddo
enddo ! iblock
!***
!*** do NOT perform halo updates now, because vector updates must
!*** be done after the rotation is completed.
!***
!-----------------------------------------------------------------------
!
! rotate true zonal/meridional wind stress into local coordinates,
! convert to dyne/cm**2, and shift SMFT to U grid
!
! halo updates are performed in subroutine rotate_wind_stress,
! following the rotation
!
!-----------------------------------------------------------------------
call rotate_wind_stress(WORK1, WORK2)
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
!-----------------------------------------------------------------------
!
! unpack and distribute fresh water flux and salt flux
!
! NOTE: if there are code changes associated with changing the names or
! the number of fluxes received from the coupler, then subroutine
! update_ghost_cells_coupler_fluxes will need to be modified also
!
!-----------------------------------------------------------------------
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
SNOW_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_snow,n)
WORKB (i,j ) = x2o_o%rAttr(index_x2o_Foxx_rain,n)
EVAP_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_evap,n)
MELT_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_meltw,n)
ROFF_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Forr_roff,n)
IOFF_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Forr_ioff,n)
SALT_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_salt,n)
PREC_F(i,j,iblock) = WORKB(i,j) + SNOW_F(i,j,iblock) ! rain + snow
WORKB(i,j ) = x2o_o%rAttr(index_x2o_Foxx_swnet,n)
SHF_QSW(i,j,iblock) = WORKB(i,j)* &
RCALCT(i,j,iblock)*hflux_factor ! convert from W/m**2
SENH_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_sen,n)
LWUP_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_lwup,n)
LWDN_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_lwdn,n)
MELTH_F(i,j,iblock) = x2o_o%rAttr(index_x2o_Foxx_melth,n)
WORKB(i,j ) = x2o_o%rAttr(index_x2o_Si_ifrac,n)
IFRAC(i,j,iblock) = WORKB(i,j) * RCALCT(i,j,iblock)
!*** converting from Pa to dynes/cm**2
WORKB(i,j ) = x2o_o%rAttr(index_x2o_Sa_pslv,n)
ATM_PRESS(i,j,iblock) = c10 * WORKB(i,j) * RCALCT(i,j,iblock)
!*** converting from m**2/s**2 to cm**2/s**2
WORKB(i,j ) = x2o_o%rAttr(index_x2o_Sx_duu10n,n)
U10_SQR(i,j,iblock) = cmperm * cmperm * WORKB(i,j) * RCALCT(i,j,iblock)
enddo
enddo
enddo
!-----------------------------------------------------------------------
!
! incoming data quality control
!
!-----------------------------------------------------------------------
#ifdef CCSMCOUPLED
if ( any(IOFF_F < c0) ) then
call shr_sys_abort ('Error: incoming IOFF_F is negative')
endif
#endif
!-----------------------------------------------------------------------
!
! update ghost cells for fluxes received from the coupler
!
!-----------------------------------------------------------------------
call update_ghost_cells_coupler_fluxes(errorCode)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'ocn_import_mct: error in update_ghost_cells_coupler_fluxes')
return
endif
!-----------------------------------------------------------------------
!
! unpack atmospheric CO2
!
!-----------------------------------------------------------------------
if (index_x2o_Sa_co2prog > 0) then
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
WORK1(i,j,iblock) = x2o_o%rAttr(index_x2o_Sa_co2prog,n)
enddo
enddo
enddo
call POP_HaloUpdate(WORK1,POP_haloClinic, &
POP_gridHorzLocCenter, &
POP_fieldKindScalar, errorCode, &
fillValue = 0.0_POP_r8)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'ocn_import_mct: error updating PROG CO2 halo')
return
endif
call named_field_set(ATM_CO2_PROG_nf_ind, WORK1)
endif
if (index_x2o_Sa_co2diag > 0) then
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
WORK1(i,j,iblock) = x2o_o%rAttr(index_x2o_Sa_co2diag,n)
enddo
enddo
enddo
call POP_HaloUpdate(WORK1,POP_haloClinic, &
POP_gridHorzLocCenter, &
POP_fieldKindScalar, errorCode, &
fillValue = 0.0_POP_r8)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'ocn_import_mct: error updating DIAG CO2 halo')
return
endif
call named_field_set(ATM_CO2_DIAG_nf_ind, WORK1)
endif
!-----------------------------------------------------------------------
!
! receive orbital parameters
!
!-----------------------------------------------------------------------
call seq_infodata_GetData(infodata, &
orb_eccen=orb_eccen, orb_mvelpp=orb_mvelpp, orb_lambm0=orb_lambm0, orb_obliqr=orb_obliqr)
!-----------------------------------------------------------------------
!
! diagnostics
!
!-----------------------------------------------------------------------
if (ldiag_cpl) then
write(message,'(6a,1x,5a)') &
' Global averages of fluxes received from cpl at ', &
cyear,'/',cmonth ,'/',cday, chour,':',cminute,':',csecond
call document ('pop_recv_from_coupler', trim(message))
m2percm2 = mpercm*mpercm
do k = 1,nrecv
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
WORK1(i,j,iblock) = x2o_o%rAttr(k,n) ! mult. by TAREA in global_sum_prod
enddo
enddo
enddo
gsum = global_sum_prod(WORK1 , TAREA, distrb_clinic, &
field_loc_center, RCALCT)*m2percm2
if (my_task == master_task) then
call seq_flds_getField(label,k,seq_flds_x2o_fields)
write(stdout,1100)'ocn','recv', label ,gsum
call shr_sys_flush(stdout)
endif
enddo
endif
1100 format ('comm_diag ', a3, 1x, a4, 1x, a8, 1x, es26.19:, 1x, a6)
!-----------------------------------------------------------------------
!EOC
end subroutine ocn_import_mct
!***********************************************************************
!BOP
! !IROUTINE: ocn_export_mct
! !INTERFACE:
subroutine ocn_export_mct(o2x_o, errorCode) 2,16
! !DESCRIPTION:
! This routine calls the routines necessary to send pop fields to
! the CCSM cpl7 driver
!
! !REVISION HISTORY:
! same as module
!
! !INPUT/OUTPUT PARAMETERS:
type(mct_aVect) , intent(inout) :: o2x_o
! !OUTPUT PARAMETERS:
integer (POP_i4), intent(out) :: &
errorCode ! returned error code
!EOP
!BOC
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
integer (int_kind) :: n, iblock
character (char_len) :: label
integer (int_kind) :: &
i,j,k
real (r8), dimension(nx_block,ny_block) :: &
WORK1, WORK2, &! local work space
WORK3, WORK4
real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: &
WORKA ! local work space with full block dimension
real (r8) :: &
m2percm2, &
gsum
type (block) :: this_block ! local block info
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!
! initialize control buffer
!
!-----------------------------------------------------------------------
errorCode = POP_Success
!-----------------------------------------------------------------------
!
! interpolate onto T-grid points and rotate on T grid
!
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
call ugrid_to_tgrid(WORK3,SBUFF_SUM(:,:,iblock,index_o2x_So_u),iblock)
call ugrid_to_tgrid(WORK4,SBUFF_SUM(:,:,iblock,index_o2x_So_v),iblock)
WORK1 = (WORK3*cos(ANGLET(:,:,iblock))+WORK4*sin(-ANGLET(:,:,iblock))) &
* mpercm/tlast_coupled
WORK2 = (WORK4*cos(ANGLET(:,:,iblock))-WORK3*sin(-ANGLET(:,:,iblock))) &
* mpercm/tlast_coupled
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
o2x_o%rAttr(index_o2x_So_u,n) = WORK1(i,j)
o2x_o%rAttr(index_o2x_So_v,n) = WORK2(i,j)
enddo
enddo
enddo
!-----------------------------------------------------------------------
!
! convert and pack surface temperature
!
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
o2x_o%rAttr(index_o2x_So_t,n) = &
SBUFF_SUM(i,j,iblock,index_o2x_So_t)/tlast_coupled + T0_Kelvin
enddo
enddo
enddo
!-----------------------------------------------------------------------
!
! convert and pack salinity
!
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
o2x_o%rAttr(index_o2x_So_s,n) = &
SBUFF_SUM(i,j,iblock,index_o2x_So_s)*salt_to_ppt/tlast_coupled
enddo
enddo
enddo
!-----------------------------------------------------------------------
!
! interpolate onto T-grid points, then rotate on T grid
!
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
call ugrid_to_tgrid(WORK3,SBUFF_SUM(:,:,iblock,index_o2x_So_dhdx),iblock)
call ugrid_to_tgrid(WORK4,SBUFF_SUM(:,:,iblock,index_o2x_So_dhdy),iblock)
WORK1 = (WORK3*cos(ANGLET(:,:,iblock)) + WORK4*sin(-ANGLET(:,:,iblock))) &
/grav/tlast_coupled
WORK2 = (WORK4*cos(ANGLET(:,:,iblock)) - WORK3*sin(-ANGLET(:,:,iblock))) &
/grav/tlast_coupled
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
o2x_o%rAttr(index_o2x_So_dhdx,n) = WORK1(i,j)
o2x_o%rAttr(index_o2x_So_dhdy,n) = WORK2(i,j)
enddo
enddo
enddo
!-----------------------------------------------------------------------
!
! pack heat flux due to freezing/melting (W/m^2)
! QFLUX computation and units conversion occurs in ice.F
!
!-----------------------------------------------------------------------
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
o2x_o%rAttr(index_o2x_Fioo_q,n) = QFLUX(i,j,iblock)
enddo
enddo
enddo
tlast_ice = c0
AQICE = c0
QICE = c0
!-----------------------------------------------------------------------
!
! pack co2 flux, if requested (kg CO2/m^2/s)
! units conversion occurs where co2 flux is computed
!
!-----------------------------------------------------------------------
if (index_o2x_Faoo_fco2 > 0) then
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
o2x_o%rAttr(index_o2x_Faoo_fco2,n) = &
SBUFF_SUM(i,j,iblock,index_o2x_Faoo_fco2)/tlast_coupled
enddo
enddo
enddo
endif
!-----------------------------------------------------------------------
!
! diagnostics
!
!-----------------------------------------------------------------------
if (ldiag_cpl) then
call ccsm_char_date_and_time
!DEBUG write(message,'(6a,1x,5a)')' Global averages of fluxes sent to cpl at ', &
!DEBUG cyear,'/',cmonth, '/',cday, chour,':',cminute,':',csecond
!DEBUG call document ('pop_send_to_coupler', message)
write(stdout,*)'pop_send_to_coupler'
m2percm2 = mpercm*mpercm
do k = 1,nsend
n = 0
do iblock = 1, nblocks_clinic
this_block = get_block(blocks_clinic(iblock),iblock)
do j=this_block%jb,this_block%je
do i=this_block%ib,this_block%ie
n = n + 1
WORKA(i,j,iblock) = o2x_o%rAttr(k,n)
enddo
enddo
enddo
call POP_HaloUpdate(WORKA,POP_haloClinic, &
POP_gridHorzLocCenter, &
POP_fieldKindScalar, errorCode, &
fillValue = 0.0_POP_r8)
if (errorCode /= POP_Success) then
call POP_ErrorSet(errorCode, &
'ocn_export_mct: error updating halo for state')
return
endif
gsum = global_sum_prod(WORKA , TAREA, distrb_clinic, &
field_loc_center, RCALCT)*m2percm2
if (my_task == master_task) then
call seq_flds_getField(label,k,seq_flds_o2x_fields)
write(stdout,1100)'ocn','send', label ,gsum
endif
enddo ! k
if (my_task == master_task) call shr_sys_flush(stdout)
endif
1100 format ('comm_diag ', a3, 1x, a4, 1x, a8, 1x, es26.19:, 1x, a6)
tlast_coupled = c0
!-----------------------------------------------------------------------
!EOC
end subroutine ocn_export_mct
!***********************************************************************
!BOP
! !IROUTINE: pop_sum_buffer
! !INTERFACE:
subroutine pop_sum_buffer 2,2
! !DESCRIPTION:
! This routine accumulates sums for averaging fields to
! be sent to the coupler
!
! !REVISION HISTORY:
! same as module
!
!EOP
!BOC
#ifdef CCSMCOUPLED
!-----------------------------------------------------------------------
!
! local variables
!
!-----------------------------------------------------------------------
real (r8), dimension(nx_block,ny_block,max_blocks_clinic) :: &
WORK ! local work arrays
real (r8) :: &
delt, & ! time interval since last step
delt_last ! time interval for previous step
integer (int_kind) :: &
iblock, & ! block index
sflux_co2_nf_ind = 0! named field index of fco2
logical (log_kind) :: &
first = .true. ! only true for first call
!-----------------------------------------------------------------------
!
! zero buffer if this is the first time after a coupling interval
!
!-----------------------------------------------------------------------
if (tlast_coupled == c0) SBUFF_SUM = c0
!-----------------------------------------------------------------------
!
! update time since last coupling
!
!-----------------------------------------------------------------------
if (avg_ts .or. back_to_back) then
delt = p5*dtt
else
delt = dtt
endif
tlast_coupled = tlast_coupled + delt
!-----------------------------------------------------------------------
!
! allow for fco2 field to not be registered on first call
! because init_forcing is called before init_passive_tracers
! use weight from previous timestep because flux used here is that
! computed during the previous timestep
!
!-----------------------------------------------------------------------
if (index_o2x_Faoo_fco2 > 0) then
if (sflux_co2_nf_ind == 0) then
call named_field_get_index('SFLUX_CO2', sflux_co2_nf_ind, &
exit_on_err=.not. first)
endif
if (avg_ts .or. back_to_back) then
delt_last = p5*dtt
else
delt_last = dtt
endif
endif
!-----------------------------------------------------------------------
!
! accumulate sums of U,V,T,S and GRADP
! accumulate sum of co2 flux, if requested
! implicitly use zero flux if fco2 field not registered yet
! ice formation flux is handled separately in ice routine
!
!-----------------------------------------------------------------------
!$OMP PARALLEL DO PRIVATE(iblock)
do iblock = 1, nblocks_clinic
SBUFF_SUM(:,:,iblock,index_o2x_So_u) = &
SBUFF_SUM(:,:,iblock,index_o2x_So_u) + delt* &
UVEL(:,:,1,curtime,iblock)
SBUFF_SUM(:,:,iblock,index_o2x_So_v) = &
SBUFF_SUM(:,:,iblock,index_o2x_So_v) + delt* &
VVEL(:,:,1,curtime,iblock)
SBUFF_SUM(:,:,iblock,index_o2x_So_t ) = &
SBUFF_SUM(:,:,iblock,index_o2x_So_t ) + delt* &
TRACER(:,:,1,1,curtime,iblock)
SBUFF_SUM(:,:,iblock,index_o2x_So_s ) = &
SBUFF_SUM(:,:,iblock,index_o2x_So_s ) + delt* &
TRACER(:,:,1,2,curtime,iblock)
SBUFF_SUM(:,:,iblock,index_o2x_So_dhdx) = &
SBUFF_SUM(:,:,iblock,index_o2x_So_dhdx) + delt* &
GRADPX(:,:,curtime,iblock)
SBUFF_SUM(:,:,iblock,index_o2x_So_dhdy) = &
SBUFF_SUM(:,:,iblock,index_o2x_So_dhdy) + delt* &
GRADPY(:,:,curtime,iblock)
if (index_o2x_Faoo_fco2 > 0 .and. sflux_co2_nf_ind > 0) then
call named_field_get(sflux_co2_nf_ind, iblock, WORK(:,:,iblock))
SBUFF_SUM(:,:,iblock,index_o2x_Faoo_fco2) = &
SBUFF_SUM(:,:,iblock,index_o2x_Faoo_fco2) + delt_last*WORK(:,:,iblock)
endif
enddo
!$OMP END PARALLEL DO
first = .false.
#endif
!-----------------------------------------------------------------------
!EOC
end subroutine pop_sum_buffer
!***********************************************************************
end module ocn_comp_mct
!|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||