#include #include module driver !----------------------------------------------------------------------- !BOP ! ! !MODULE: driver ! ! !DESCRIPTION: ! This module provides the main CLM driver calling sequence. Most ! computations occurs over ``clumps'' of gridcells (and associated subgrid ! scale entities) assigned to each MPI process. Computation is further ! parallelized by looping over clumps on each process using shared memory ! OpenMP or Cray Streaming Directives. ! ! !USES: use shr_kind_mod , only : r8 => shr_kind_r8 use shr_cal_mod , only : shr_cal_ymd2julian, shr_cal_numDaysInYear use shr_sys_mod , only : shr_sys_flush use clmtype use clm_atmlnd use clm_varctl , only : wrtdia, fpftdyn, fndepdyn, caseid, calendar use clm_varctl , only : iulog, vicrst_interval use clm_varctl , only : outstream_freqs, outstream_modes, NUM_OUTSTRMS, MAX_OUTSTRMS, ON use clm_varpar , only : lsmlon, lsmlat use spmdMod , only : masterproc,mpicom use decompMod , only : get_proc_clumps, get_clump_bounds, ldecomp use filterMod , only : filter, setFilters use pftdynMod , only : pftdyn_interp, pftdyn_wbal_init, pftdyn_wbal, pftdyn_cnbal use clm_varcon , only : zlnd, isturb use clm_time_manager , only : get_step_size, get_curr_calday, & get_curr_date, get_ref_date, get_nstep, is_perpetual use histFileMod , only : hist_update_hbuf, hist_htapes_wrapup use restFileMod , only : restFile_write, restFile_write_binary, restFile_filename use inicFileMod , only : inicfile_perp use accFldsMod , only : updateAccFlds use DriverInitMod , only : DriverInit use BalanceCheckMod , only : BeginWaterBalance, BalanceCheck use SurfaceRadiationMod , only : SurfaceRadiation use Hydrology1Mod , only : Hydrology1 use Hydrology2Mod , only : Hydrology2 use HydrologyLakeMod , only : HydrologyLake use Biogeophysics1Mod , only : Biogeophysics1 use BareGroundFluxesMod , only : BareGroundFluxes use CanopyFluxesMod , only : CanopyFluxes use Biogeophysics2Mod , only : Biogeophysics2 use BiogeophysicsLakeMod, only : BiogeophysicsLake use SurfaceAlbedoMod , only : SurfaceAlbedo, Snowage use pft2colMod , only : pft2col #if (defined DGVM) use DGVMEcosystemDynMod , only : DGVMEcosystemDyn, DGVMRespiration use DGVMMod , only : lpj, lpjreset, histDGVM, & resetweightsdgvm, resettimeconstdgvm #elif (defined CN) use CNEcosystemDynMod , only : CNEcosystemDyn use CNAnnualUpdateMod , only : CNAnnualUpdate use CNBalanceCheckMod , only : BeginCBalance, BeginNBalance, & CBalanceCheck, NBalanceCheck use ndepFileMod , only : ndepdyn_interp #else use STATICEcosysDynMod , only : EcosystemDyn, interpMonthlyVeg #endif #if (defined DUST) use DUSTMod , only : DustDryDep, DustEmission #endif #if (defined VOC) use VOCEmissionMod , only : VOCEmission #endif #if (defined CASA) use CASAPhenologyMod , only : CASAPhenology use CASAMod , only : Casa #if (defined CLAMP) use CASASummaryMod , only : CASASummary #endif #endif #if (defined RTM) use RtmMod , only : Rtmriverflux #endif use abortutils , only : endrun use UrbanMod , only : UrbanAlbedo, UrbanRadiation, UrbanFluxes use perf_mod ! ! !PUBLIC TYPES: implicit none ! ! !PUBLIC MEMBER FUNCTIONS: public :: driver1 public :: driver2 ! ! !PRIVATE MEMBER FUNCTIONS: private :: write_diagnostic private :: do_restwrite private :: do_inicwrite private :: writestate private :: writereset !----------------------------------------------------------------------- contains !----------------------------------------------------------------------- ! ! !ROUTINE: driver1 ! ! !INTERFACE: subroutine driver1 (doalb, caldayp1, declinp1, rstwr, rdate) ! ! !ARGUMENTS: implicit none logical , intent(in) :: doalb ! true if time for surface albedo calc real(r8), intent(in) :: caldayp1 ! calendar day for nstep+1 real(r8), intent(in) :: declinp1 ! declination angle for next time step logical, optional, intent(in) :: rstwr ! true => write restart file this step character(len=*), optional, intent(in) :: rdate ! restart file time stamp for name ! ! !REVISION HISTORY: ! 2002.10.01 Mariana Vertenstein latest update to new data structures ! 11/26/03, Peter Thornton: Added new call for SurfaceRadiationSunShade when ! cpp directive SUNSHA is set, for sunlit/shaded canopy radiation. ! 4/25/05, Peter Thornton: Made the sun/shade routine the default, no longer ! need to have SUNSHA defined. ! !EOP ! ! !LOCAL VARIABLES: ! ! local pointers to implicit in arguments ! integer , pointer :: clandunit(:) ! landunit index associated with each column integer , pointer :: itypelun(:) ! landunit type ! ! !OTHER LOCAL VARIABLES: real(r8) :: t1, t2, t3, dtime ! temporary for mass balance checks integer :: n, nc, fc, c, fp, p, l ! indices integer :: nclumps ! number of clumps on this processor integer :: g, output_interval, reset, nstep, output_nstep, checkwrite, checkaccum, checkmode, vicrst_nstep, checkrst ! time step number integer, dimension (7) :: vicdate ! date info for VIC integer, dimension (7) :: cpldate ! date info for VIC integer, dimension (MAX_OUTSTRMS+1) :: tmp_checkwrite integer, dimension (MAX_OUTSTRMS) :: outstream_resets integer, dimension (MAX_OUTSTRMS) :: outstream_writes integer :: count, countout ! count timestep for restarting and ! outputing by chunmei ! character(len=400) :: SAVENAME_VIC = './restart_vic' ! restarting filename by chunmei ! character(len=800) :: OUTPUTNAME_VIC ! VIC output file name by Chunmei character(len=16) :: vdate character(len=64) :: cal_type = ' ' integer :: yr, mon, day, sec, hr, mn, second, edays ! real(r8) :: rdays integer :: totalcells integer :: begp, endp ! clump beginning and ending pft indices integer :: begc, endc ! clump beginning and ending column indices integer :: begl, endl ! clump beginning and ending landunit indices integer :: begg, endg ! clump beginning and ending gridcell indices ! VICP - BEGIN DRIVER1 ! VICP - Added flags for MPI communication ! VICP - msend_flag: all data distribution operations to slaves have completed ! VICP - ssend_flag: all data distribution operations to master have completed ! VICP - mrecv_flag: all data update operations from slaves have completed ! VICP - macc_flag: all accum_data output data from slaves have been received ! VICP - sacc_flag: all accum_data output data to master have been sent and acknowledged integer :: msend_flag, ssend_flag, mrecv_flag, macc_flag, sacc_flag ! flags for MPI communication ! integer :: ier type(column_type) , pointer :: cptr ! pointer to column derived subtype !----------------------------------------------------------------------- ! ============================================================================ ! Calendar information for next time step ! o caldayp1 = calendar day (1.00 -> 365.99) for cosine solar zenith angle ! calday is based on Greenwich time ! o get_curr_calday in the cam time manager know about perpetual mode ! and perpetual model is only used within cam ! ============================================================================ dtime = get_step_size() call get_curr_date (yr, mon, day, sec) hr = sec/3600 mn = mod (sec, 3600)/60 second = sec - 3600*hr - mn*60 vicdate(1) = yr vicdate(2) = mon vicdate(3) = day vicdate(4) = hr vicdate(5) = mn vicdate(6) = second !! if (masterproc) write(iulog,*) 'check vicdate in driver', vicdate(1),vicdate(2), vicdate(3), vicdate(4), vicdate(5), vicdate(6) nstep = get_nstep () vicrst_nstep = vicrst_interval/dtime !! if (masterproc) write(iulog,*) 'JCR driver-CHECK nstep = ', nstep, ' dtime = ', dtime !!if (masterproc) write(iulog,*) 'JCR driver-CHECK vicrst_nstep = ', vicrst_nstep ! update calendar information for netcdf if ( trim(calendar) == 'NO_LEAP' ) then cal_type = 'noleap' else if ( trim(calendar) == 'GREGORIAN' ) then cal_type = 'gregorian' else write(iulog,*) ': unrecognized calendar specified: ',calendar call endrun end if totalcells = lsmlon*lsmlat !! VIC restarting !! write(iulog,*) 'driver1 check ',rstwr checkrst = 0 ! VICP - Determine whether restart or accum data file are to be written this cycle ! VICP - Used in loop to better interleave communication and calculation ! VICP - changed to make more consistent - may have been bad idea.... !! if (vicrst_nstep > 0) checkrst = mod(nstep, vicrst_nstep ) if (vicrst_nstep > 0) checkrst = mod(nstep, vicrst_nstep ) + 1 if (present(rstwr)) then checkrst = 0 if (rstwr) checkrst = 1 endif !!GORP - for testing !! checkrst = 0 !!GORP ! VICP - initialize flags for cleanup after loop if ((masterproc) .AND. (nstep == 1)) then msend_flag = 1 else msend_flag = 0 endif if ( nstep > 1 .AND. checkrst == 1) then if (present(rdate)) then vdate = trim(rdate) else write(vdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec endif !! write(iulog,*) 'vic write restart ',vdate !! call outsavvic(vdate, lsmlon*lsmlat) endif !! GORP - for testing !! if (nstep .eq. 5) then !! checkrst = 1 !! else !! checkrst = 0 !! endif ! VICP - checkwrite and countout seem to do the same thing. If son, this should be cleaned up... tmp_checkwrite = writestate() outstream_writes(1) = tmp_checkwrite(1) outstream_writes(2) = tmp_checkwrite(2) outstream_writes(3) = tmp_checkwrite(3) outstream_writes(4) = tmp_checkwrite(4) checkwrite = tmp_checkwrite(5) outstream_resets = writereset() call set_freq_mask(outstream_freqs, outstream_modes, outstream_writes, outstream_resets, NUM_OUTSTRMS) !! if (masterproc) then !! write(iulog, *) 'JCR checkwrite= ', checkwrite !! write(iulog, *) 'JCR outstream_writes= ', outstream_writes !! write(iulog, *) 'JCR outstream_resets= ', outstream_resets !! write(iulog, *) 'JCR outstream_freqs= ', outstream_freqs !! write(iulog, *) 'JCR outstream_modes= ', outstream_modes !! write(iulog, *) 'JCR NUM_OUTSTRMS=', NUM_OUTSTRMS !! endif if ( nstep > 0 ) then ! ============================================================================ ! Loop over clumps ! ============================================================================ nclumps = get_proc_clumps() !$OMP PARALLEL DO PRIVATE (nc,begg,endg,g) #if !defined (USE_OMP) !!CSD$ PARALLEL DO PRIVATE (nc,begg,endg,g)) #endif do nc = 1,nclumps ! ============================================================================ ! Determine clump boundaries ! ============================================================================ call get_clump_bounds(nc, begg, endg) !! if (masterproc) write(iulog,*) 'check bounds: ',begg, endg !! if (masterproc) write(iulog,*) 'nc, nclumps: ', nc, nclumps !! call shr_sys_flush(iulog) ! VICP - Get distribution for this set of clumps. Only tested for nclumps = 1 call pass_mpi_clump(begg, endg) do g = begg, endg ! write(iulog,*) 'driver1 check clm_a2l: g=',g ! write(iulog,*) 'driver1 forc_wind=', clm_a2l%forc_wind(g), 'forc_pbot=', clm_a2l%forc_pbot(g), 'forc_lwrad=', clm_a2l%forc_lwrad(g), 'forc_solar=', clm_a2l%forc_solar(g), 'forc_rain=', clm_a2l%forc_rain(g), 'forc_t=', clm_a2l%forc_t(g) ! write(iulog,*) 'driver1 forc_solar=', clm_a2l%forc_solar(g) ! call shr_sys_flush(iulog) ! VICP - Distribute initial data ! VICP - master has 2 posted sends active to each slave to minimize synchronization costs ! VICP - slave has blocking receive, since it can't do anything without data ! VICP - tag appended with "1" to keep different types of communication separate if (nstep .eq. 1) then if (masterproc) then call msend_mpi_prcp(1, msend_flag) else call srecv_mpi_prcp(begg, g, 1, ldecomp%gdc2glo(g)) endif !! if (masterproc) write(iulog,*) 'Sent prcp: ',begg, endg endif call t_startf('vicmodelwrf') !! if (masterproc) write(iulog,*) 'Started vicmodelwrf: ',begg, endg ! Added lowest model level clm_a2l%forc_hgt(g), so that VIC can use WRF's ! lowest model level for its reference height. Also added a new ! clm_l2a%logz0(g) to pass a vegetation-weighted log(Z0) to the coupler - BN ! clm_l2a%rofice(g) and clm2a%rofliq(g) to pass ice and liquid runoff fluxes to the coupler - BN call vicmodelwrf(g, begg, ldecomp%gdc2glo(g), vicdate, nstep, dtime, & totalcells, clm_a2l%forc_hgt(g), clm_a2l%forc_q(g), & clm_a2l%forc_wind(g), clm_a2l%forc_u(g), clm_a2l%forc_v(g), & clm_a2l%forc_rho(g), clm_a2l%forc_pbot(g), clm_a2l%forc_lwrad(g), & clm_a2l%forc_solar(g), clm_a2l%rainf(g), clm_a2l%forc_t(g), & clm_l2a%t_rad(g), clm_l2a%h2osno(g), clm_l2a%t_ref2m(g), & clm_l2a%q_ref2m(g), clm_l2a%eflx_lh_tot(g), clm_l2a%eflx_sh_tot(g), & clm_l2a%albd(g,1), clm_l2a%albd(g,2), clm_l2a%albi(g,1), & clm_l2a%albi(g,2), clm_l2a%qflx_evap_tot(g), clm_l2a%taux(g), & clm_l2a%tauy(g), clm_l2a%fv(g), clm_l2a%logz0(g), clm_l2a%rofice(g), & clm_l2a%rofliq(g), clm_l2a%fsa(g), clm_l2a%eflx_lwrad_out(g)) call t_stopf('vicmodelwrf') ! write(iulog,*) 'driver1 Completed vicmodelwrf: nstep ', nstep, ', processor ', iam, ', cell ', g, ' of ', endg ! call shr_sys_flush(iulog) ! VICP - send prcp data back to master to output restart file ! VICP - master has one posted receive active per slave ! VICP - slave has 2 posted sends active to minimize synchronization costs ! VICP - tag appended with "2" to keep different types of communication separate if ( nstep > 1 .AND. checkrst == 1) then if (masterproc) then call mrecv_mpi_prcp(2, mrecv_flag) else call ssend_mpi_prcp(g, 2, ssend_flag) endif endif ! VICP - send accum data to master to output accum data output file ! VICP - master has one posted receive active per slave ! VICP - slave has 2 posted sends active to minimize synchronization costs ! VICP - tag appended with "4" to keep different types of communication separate if ( nstep > 1 .AND. checkwrite == ON) then if (masterproc) then call mrecv_mpi_acc(4, macc_flag) else call ssend_mpi_acc(g, 4, sacc_flag) endif endif ! clm_l2a%tauy(g) = clm_l2a%taux(g) ! clm_l2a%albd(g,2) = clm_l2a%albd(g,1) ! clm_l2a%albi(g,1) = clm_l2a%albd(g,1) ! clm_l2a%albi(g,2) = clm_l2a%albd(g,1) clm_l2a%nee(g) = 0 !! if (masterproc) write(iulog,*) 'nstep=', nstep, 't_rad=', clm_l2a%t_rad(g),'q_ref2m=', clm_l2a%q_ref2m(g), 'eflx_lh_tot=', clm_l2a%eflx_lh_tot(g), 'eflx_sh_tot=', clm_l2a%eflx_sh_tot(g), 'taux=', clm_l2a%taux(g), 'tauy=',clm_l2a%tauy(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep, 't_ref2m=', clm_l2a%t_ref2m(g),'t_rad=', clm_l2a%t_rad(g) !! 'snow=', clm_l2a%h2osno(g), 'albd1=', clm_l2a%albd(g,1), 'albd2=', clm_l2a%albd(g,2), 'albi1=', clm_l2a%albi(g,1), 'albi2=', clm_l2a%albi(g,2) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep, 'evap=', clm_l2a%qflx_evap_tot(g), 'fsa=', clm_l2a%fsa(g), 'lwrad=', clm_l2a%eflx_lwrad_out(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'eflx_sh_tot=', clm_l2a%eflx_sh_tot(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'eflx_lh_tot=', clm_l2a%eflx_lh_tot(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'t_rad=', clm_l2a%t_rad(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'taux=', clm_l2a%taux(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'tauy=', clm_l2a%tauy(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'t_ref2m=', clm_l2a%t_ref2m(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'q_ref2m=', clm_l2a%q_ref2m(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'fsa=', clm_l2a%fsa(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'eflx_lwrad_out=', clm_l2a%eflx_lwrad_out(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'h2osno=', clm_l2a%h2osno(g) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'albd1=', clm_l2a%albd(g,1) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'albd2=', clm_l2a%albd(g,2) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'albi1=', clm_l2a%albi(g,1) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep,'albi2=', clm_l2a%albi(g,2) !! if (masterproc) write(iulog,*) 'g=',g, 'nstep=', nstep !! call flush(iulog) enddo !! GORP !! if (masterproc) write(iulog,*) 'Flushing prcp communication buffers' !! call shr_sys_flush(iulog) ! VICP - my personal timer function ! call vic_timer_beg ! VICP - end-of-loop cleanup of all pending communication ! VICP - each communication type sets flags depending on whether it is active or not ! VICP - then loops send or receive calls to complete ! VICP - for slaves, "-1" indicates all sends have been posted, just check for completion if (masterproc) then if (nstep > 1 .AND. checkrst == 1) then mrecv_flag = 1 else mrecv_flag = 0 endif do while ((msend_flag .eq. 1).or.(mrecv_flag .eq. 1)) if (msend_flag .eq. 1) then call msend_mpi_prcp(1, msend_flag) endif if (mrecv_flag .eq. 1) then call mrecv_mpi_prcp(2, mrecv_flag) endif enddo if (nstep > 1 .AND. checkwrite == ON ) then macc_flag = 1 else macc_flag = 0 endif do while (macc_flag .eq. 1) call mrecv_mpi_acc(4, macc_flag) enddo else if (nstep > 1 .AND. checkrst == 1) then ssend_flag = 1 else ssend_flag = 0 endif do while (ssend_flag .eq. 1) call ssend_mpi_prcp(-1, 2, ssend_flag) enddo if (nstep > 1 .AND. checkwrite == ON ) then sacc_flag = 1 else sacc_flag = 0 endif do while (sacc_flag .eq. 1) call ssend_mpi_acc(-1, 4, sacc_flag) enddo endif ! VICP - again, my personal timer ! call vic_timer_end ! call vic_timer_diff call shr_sys_flush(iulog) ! VICP - clean up sending and receiving of out_data files ! VICP - this is a bit more complex since they are set up and called in-loop, ! VICP - but only master writes to file ! VICP - END DRIVER1 call clear_output() call shr_sys_flush(iulog) enddo endif !! VIC restarting !! GORP Commenting out lines below !!write(iulog,*) 'driver1 check ',rstwr !!checkrst = 0 !!if (vicrst_nstep > 0) checkrst = mod(nstep, vicrst_nstep ) !!if (present(rstwr)) then !! checkrst = 0 !! if (rstwr) checkrst = 1 !!endif !! if (masterproc) write(iulog,*) 'JCR checkrst = ', checkrst, ' checkwrite = ', checkwrite if ( nstep > 1 .AND. checkrst == 1) then !! if (masterproc) write(iulog,*) 'JCR vic write restart ',vdate !! if (masterproc) write(iulog,*) 'JCR entering outsavvic' if (masterproc) call outsavvic(lsmlon*lsmlat, vicdate, trim(caseid)//char(0)) !! if (masterproc) write(iulog,*) 'JCR returned from outsavvic' !! call shr_sys_flush(iulog) endif !! checkwrite = mod(nstep, output_nstep ) !! GORP if (masterproc .AND. nstep > 0 .AND. checkwrite == ON) then !! write(iulog,*) 'JCR entering wrf_write_data' ! edays is integer days only at this point ! call shr_cal_ymd2julian(yr,mon,day,0,rdays,cal_type) edays = nint(rdays) do n = 0,yr-1 edays = edays + shr_cal_numDaysinYear(yr,cal_type) enddo call wrf_write_data(vicdate, lsmlon*lsmlat, edays, trim(caseid)//char(0), trim(cal_type)//char(0)) !! write(iulog,*) 'JCR returned from wrf_write_data' !! call shr_sys_flush(iulog) endif ! call mpi_barrier(mpicom, ier) !! if (masterproc) write(iulog,*) 'after VICmodel parrell in driver1' !! call flush(iulog) !! if (masterproc) write(iulog,*) 'before leaving driver1' !! call flush(iulog) end subroutine driver1 !----------------------------------------------------------------------- ! ! !ROUTINE: driver2 ! ! !INTERFACE: subroutine driver2(caldayp1, declinp1, rstwr, nlend, rdate) ! ! !ARGUMENTS: implicit none real(r8), intent(in) :: caldayp1 ! calendar day for nstep+1 real(r8), intent(in) :: declinp1 ! declination angle for next time step logical, optional, intent(in) :: rstwr ! true => write restart file this step logical, optional, intent(in) :: nlend ! true => end of run on this step character(len=*), optional, intent(in) :: rdate ! restart file time stamp for name ! ! !REVISION HISTORY: ! 2005.05.22 Mariana Vertenstein creation ! !EOP ! ! !LOCAL VARIABLES: integer :: nstep ! time step number real(r8) :: dtime ! land model time step (sec) #if (defined DGVM) integer :: nc, c ! indices integer :: nclumps ! number of clumps on this processor integer :: yrp1 ! year (0, ...) for nstep+1 integer :: monp1 ! month (1, ..., 12) for nstep+1 integer :: dayp1 ! day of month (1, ..., 31) for nstep+1 integer :: secp1 ! seconds into current date for nstep+1 integer :: yr ! year (0, ...) integer :: mon ! month (1, ..., 12) integer :: day ! day of month (1, ..., 31) integer :: sec ! seconds of the day integer :: ncdate ! current date integer :: nbdate ! base date (reference date) integer :: kyr ! thousand years, equals 2 at end of first year integer :: begp, endp ! clump beginning and ending pft indices integer :: begc, endc ! clump beginning and ending column indices integer :: begl, endl ! clump beginning and ending landunit indices integer :: begg, endg ! clump beginning and ending gridcell indices #endif character(len=256) :: filer ! restart file name integer :: ier logical :: write_restart !----------------------------------------------------------------------- end subroutine driver2 !------------------------------------------------------------------------ !BOP ! ! !IROUTINE: write_diagnostic ! ! !INTERFACE: subroutine write_diagnostic (wrtdia, nstep) ! ! !DESCRIPTION: ! Write diagnostic surface temperature output each timestep. Written to ! be fast but not bit-for-bit because order of summations can change each ! timestep. ! ! !USES: use clm_atmlnd , only : clm_l2a use decompMod , only : get_proc_bounds, get_proc_global use spmdMod , only : masterproc, npes, MPI_REAL8, MPI_ANY_SOURCE, & MPI_STATUS_SIZE, mpicom, MPI_SUM use shr_sys_mod, only : shr_sys_flush use abortutils , only : endrun ! ! !ARGUMENTS: implicit none logical, intent(in) :: wrtdia !true => write diagnostic integer, intent(in) :: nstep !model time step ! ! !REVISION HISTORY: ! Created by Mariana Vertenstein ! !EOP ! ! !LOCAL VARIABLES: integer :: p ! loop index integer :: begp, endp ! per-proc beginning and ending pft indices integer :: begc, endc ! per-proc beginning and ending column indices integer :: begl, endl ! per-proc beginning and ending landunit indices integer :: begg, endg ! per-proc gridcell ending gridcell indices integer :: numg ! total number of gridcells across all processors integer :: numl ! total number of landunits across all processors integer :: numc ! total number of columns across all processors integer :: nump ! total number of pfts across all processors integer :: ier ! error status real(r8):: psum ! partial sum of ts real(r8):: tsum ! sum of ts real(r8):: tsxyav ! average ts for diagnostic output integer :: status(MPI_STATUS_SIZE) ! mpi status logical,parameter :: old_sendrecv = .false. !------------------------------------------------------------------------ call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) call get_proc_global(numg, numl, numc, nump) if (wrtdia) then call t_barrierf('sync_write_diag', mpicom) psum = sum(clm_l2a%t_rad(begg:endg)) if (old_sendrecv) then if (masterproc) then tsum = psum do p = 1, npes-1 call mpi_recv(psum, 1, MPI_REAL8, p, 999, mpicom, status, ier) if (ier/=0) then write(iulog,*) 'write_diagnostic: Error in mpi_recv()' call endrun end if tsum = tsum + psum end do else call mpi_send(psum, 1, MPI_REAL8, 0, 999, mpicom, ier) if (ier/=0) then write(iulog,*) 'write_diagnostic: Error in mpi_send()' call endrun end if end if else call mpi_reduce(psum, tsum, 1, MPI_REAL8, MPI_SUM, 0, mpicom, ier) if (ier/=0) then write(iulog,*) 'write_diagnostic: Error in mpi_reduce()' call endrun end if endif if (masterproc) then tsxyav = tsum / numg write(iulog,1000) nstep, tsxyav #ifndef UNICOSMP call shr_sys_flush(iulog) #endif end if else if (masterproc) then write(iulog,*)'clm2: completed timestep ',nstep #ifndef UNICOSMP call shr_sys_flush(iulog) #endif end if endif 1000 format (1x,'nstep = ',i10,' TS = ',f21.15) end subroutine write_diagnostic !------------------------------------------------------------------------ !BOP ! ! !ROUTINE: do_restwrite ! ! !INTERFACE: logical function do_restwrite() ! ! !DESCRIPTION: ! Determine if restart dataset is to be written at this time step ! ! !USES: use restFileMod , only : rest_flag #if (defined COUP_CSM) use clm_csmMod , only : csmstop_next, csmrstrt #else use clm_time_manager, only : is_last_step use histFileMod , only : if_writrest #endif ! ! !ARGUMENTS: implicit none ! ! !REVISION HISTORY: ! Created by Mariana Vertenstein ! !EOP !------------------------------------------------------------------------ do_restwrite = .false. #if (defined COUP_CSM) ! Write restart only if coupler says to if (csmrstrt) do_restwrite = .true. #endif end function do_restwrite !----------------------------------------------------------------------- !BOP ! ! !IROUTINE: do_inicwrite ! ! !INTERFACE: logical function do_inicwrite() ! ! !DESCRIPTION: ! Determine if initial dataset is to be written at this time step ! True implies that the initial file will be written one time step ! before the date contained in the filename. ! ! !USES: use clm_time_manager, only : get_curr_date, get_prev_date, get_step_size use clm_varctl , only : hist_crtinic ! ! !ARGUMENTS: implicit none ! ! !CALLED FROM: ! subroutine driver ! ! !REVISION HISTORY: ! Created by Mariana Vertenstein !EOP ! ! !LOCAL VARIABLES: integer :: yr !nstep year (0 -> ...) integer :: yrm1 !nstep-1 year (0 -> ...) integer :: daym1 !nstep-1 day (1 -> 31) integer :: day !nstep day (1 -> 31) integer :: mon !nstep month (1 -> 12) integer :: monm1 !nstep-1 month (1 -> 12) integer :: mcsec !nstep time of day [seconds] integer :: mcsecm1 !nstep-1 time of day [seconds] integer :: mcsecp1 !nstep+1 time of day [seconds] integer :: dayp1 !nstep+1 day (1 -> 31) integer :: monp1 !nstep+1 month (1 -> 12) integer :: yrp1 !nstep+1 year (0 -> ...) integer :: dtime !timestep size [seconds] !----------------------------------------------------------------------- ! Set calendar for current, previous, and next time steps dtime = get_step_size() call get_curr_date (yr , mon , day , mcsec ) call get_prev_date (yrm1, monm1, daym1, mcsecm1) call get_curr_date (yrp1, monp1, dayp1, mcsecp1, offset=dtime) ! Determine if time to write out initial dataset do_inicwrite = .false. if (hist_crtinic /= 'NONE') then if (hist_crtinic == '6-HOURLY') then if (mod(mcsecp1,21600) == 0) do_inicwrite = .true. elseif (hist_crtinic == 'DAILY') then if (day /= dayp1) do_inicwrite = .true. else if (hist_crtinic == 'MONTHLY') then if (mon /= monp1) do_inicwrite = .true. else if (hist_crtinic == 'YEARLY') then if (mon == 12 .and. monp1 == 1) do_inicwrite = .true. endif endif end function do_inicwrite !----------------------------------------------------------------------- ! !IROUTINE: writestate ! ! !INTERFACE: function writestate() ! ! !DESCRIPTION: ! Determine if dataset is to be written at this time step ! ! Integer is sum of powers of 2, corresponding to the position of the option ! in the list of possible options. Currently: ! ESTEP: 1 ! HOURLY: 2 ! DAILY: 4 ! MONTHLY: 8 ! ! !USES: use clm_time_manager, only : get_curr_date, get_prev_date, get_step_size use clm_varctl , only :outstream_freqs, MAX_OUTSTRMS, ESTEP, HOURLY, DAILY, MONTHLY, OFF, ON ! ! !ARGUMENTS: implicit none ! ! !CALLED FROM: ! subroutine driver ! ! !LOCAL VARIABLES: integer :: yr !nstep year (0 -> ...) integer :: day !nstep day (1 -> 31) integer :: mon !nstep month (1 -> 12) integer :: sec !nstep time of day [seconds] integer :: dtime !timestep size [seconds] integer :: output_freq integer :: i integer, dimension (MAX_OUTSTRMS+1) :: writestate !----------------------------------------------------------------------- ! Set calendar for current time step dtime = get_step_size() call get_curr_date (yr , mon , day , sec ) ! Determine if time to write out initial dataset writestate(MAX_OUTSTRMS+1) = OFF do i = 1 , MAX_OUTSTRMS writestate(i) = OFF output_freq = outstream_freqs(i) if (output_freq == ESTEP) then if (mod(sec,dtime) == 0) then writestate(i) = ON writestate(MAX_OUTSTRMS+1) = ON endif elseif (output_freq == HOURLY) then if (mod(sec,3600) == 0) then writestate(i) = ON writestate(MAX_OUTSTRMS+1) = ON endif elseif (output_freq == DAILY) then if (sec == 0) then writestate(i) = ON writestate(MAX_OUTSTRMS+1) = ON endif elseif (output_freq == MONTHLY) then if (day ==1 .and. sec == 0) then writestate(i) = ON writestate(MAX_OUTSTRMS+1) = ON endif endif enddo end function writestate !----------------------------------------------------------------------- ! !IROUTINE: writereset ! ! !INTERFACE: function writereset() ! ! !DESCRIPTION: ! Determines if data needs to be reset for the current time step ! ! !USES: use clm_time_manager, only : get_prev_date, get_step_size use clm_varctl , only :outstream_freqs, MAX_OUTSTRMS, ESTEP, HOURLY, DAILY, MONTHLY, OFF, ON ! ! !ARGUMENTS: implicit none ! ! !CALLED FROM: ! subroutine driver ! ! !LOCAL VARIABLES: integer :: prevyr !nstep-1 year (0 -> ...) integer :: prevday !nstep day-1 (1 -> 31) integer :: prevmon !nstep-1 month (1 -> 12) integer :: prevsec !nstep-1 time of day [seconds] integer :: dtime !timestep size [seconds] integer :: output_freq integer :: i integer, dimension (MAX_OUTSTRMS) :: writereset !----------------------------------------------------------------------- ! Set calendar for previous time step dtime = get_step_size() call get_prev_date (prevyr, prevmon, prevday, prevsec) ! Determine if time to reset dataset do i = 1 , MAX_OUTSTRMS writereset(i) = OFF output_freq = outstream_freqs(i) if ( output_freq == ESTEP) then if (mod(prevsec,dtime) == 0) writereset(i) = ON elseif ( output_freq == HOURLY) then if (mod(prevsec,3600) == 0) writereset(i) = ON elseif ( output_freq == DAILY) then if (prevsec == 0) writereset(i) = ON elseif ( output_freq == MONTHLY) then if (prevday ==1 .and. prevsec == 0) writereset(i) = ON endif enddo end function writereset end module driver