!*********************************************************************** !* GNU General Public License * !* This file is a part of fvGFS. * !* * !* fvGFS is free software; you can redistribute it and/or modify it * !* and are expected to follow the terms of the GNU General Public * !* License as published by the Free Software Foundation; either * !* version 2 of the License, or (at your option) any later version. * !* * !* fvGFS is distributed in the hope that it will be useful, but * !* WITHOUT ANY WARRANTY; without even the implied warranty of * !* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * !* General Public License for more details. * !* * !* For the full text of the GNU General Public License, * !* write to: Free Software Foundation, Inc., * !* 675 Mass Ave, Cambridge, MA 02139, USA. * !* or see: http://www.gnu.org/licenses/gpl.html * !*********************************************************************** program coupler_main !----------------------------------------------------------------------- ! ! program that couples component models for the atmosphere, ! ocean (amip), land, and sea-ice using the exchange module ! !----------------------------------------------------------------------- use time_manager_mod, only: time_type, set_calendar_type, set_time, & set_date, days_in_month, month_name, & operator(+), operator (<), operator (>), & operator (/=), operator (/), operator (==),& operator (*), THIRTY_DAY_MONTHS, JULIAN, & NOLEAP, NO_CALENDAR, date_to_string, & get_date use atmos_model_mod, only: atmos_model_init, atmos_model_end, & update_atmos_model_dynamics, & update_atmos_radiation_physics, & update_atmos_model_state, & atmos_data_type, atmos_model_restart use constants_mod, only: constants_init #ifdef INTERNAL_FILE_NML use mpp_mod, only: input_nml_file #else use fms_mod, only: open_namelist_file #endif use fms_mod, only: file_exist, check_nml_error, & error_mesg, fms_init, fms_end, close_file, & write_version_number, uppercase use mpp_mod, only: mpp_init, mpp_pe, mpp_root_pe, mpp_npes, mpp_get_current_pelist, & mpp_set_current_pelist, stdlog, mpp_error, NOTE, FATAL, WARNING use mpp_mod, only: mpp_clock_id, mpp_clock_begin, mpp_clock_end, mpp_sync use mpp_io_mod, only: mpp_open, mpp_close, & MPP_NATIVE, MPP_RDONLY, MPP_DELETE use mpp_domains_mod, only: mpp_get_global_domain, mpp_global_field, CORNER use memutils_mod, only: print_memuse_stats use sat_vapor_pres_mod,only: sat_vapor_pres_init use diag_manager_mod, only: diag_manager_init, diag_manager_end, & get_base_date, diag_manager_set_time_end use data_override_mod, only: data_override_init implicit none !----------------------------------------------------------------------- character(len=128) :: version = '$Id: coupler_main.F90,v 19.0.4.1.2.3 2014/09/09 23:51:59 Rusty.Benson Exp $' character(len=128) :: tag = '$Name: ulm_201505 $' !----------------------------------------------------------------------- !---- model defined-types ---- type (atmos_data_type) :: Atm !----------------------------------------------------------------------- ! ----- coupled model time ----- type (time_type) :: Time_atmos, Time_init, Time_end, & Time_step_atmos, Time_step_ocean, & Time_restart, Time_step_restart integer :: num_cpld_calls, num_atmos_calls, nc, na, ret ! ----- coupled model initial date ----- integer :: date_init(6) integer :: calendar_type = -99 ! ----- timing flags ----- integer :: initClock, mainClock, termClock integer, parameter :: timing_level = 1 ! ----- namelist ----- integer, dimension(6) :: current_date = (/ 0, 0, 0, 0, 0, 0 /) character(len=17) :: calendar = ' ' logical :: force_date_from_namelist = .false. ! override restart values for date integer :: months=0, days=0, hours=0, minutes=0, seconds=0 integer :: dt_atmos = 0 integer :: dt_ocean = 0 integer :: restart_days = 0 integer :: restart_secs = 0 integer :: atmos_nthreads = 1 logical :: memuse_verbose = .false. logical :: use_hyper_thread = .false. logical :: debug_affinity = .false. integer :: ncores_per_node = 0 namelist /coupler_nml/ current_date, calendar, force_date_from_namelist, & months, days, hours, minutes, seconds, & dt_atmos, dt_ocean, atmos_nthreads, memuse_verbose, & use_hyper_thread, ncores_per_node, debug_affinity, & restart_secs, restart_days ! ----- local variables ----- character(len=32) :: timestamp logical :: intrm_rst !####################################################################### call fms_init() call mpp_init() initClock = mpp_clock_id( 'Initialization' ) call mpp_clock_begin (initClock) !nesting problem call fms_init call constants_init call sat_vapor_pres_init call coupler_init call print_memuse_stats('after coupler init') call mpp_set_current_pelist() call mpp_clock_end (initClock) !end initialization mainClock = mpp_clock_id( 'Main loop' ) termClock = mpp_clock_id( 'Termination' ) call mpp_clock_begin(mainClock) !begin main loop do nc = 1, num_cpld_calls Time_atmos = Time_atmos + Time_step_atmos call update_atmos_model_dynamics (Atm) call update_atmos_radiation_physics (Atm) call update_atmos_model_state (Atm) !--- intermediate restart if (intrm_rst) then if ((nc /= num_cpld_calls) .and. (Time_atmos == Time_restart)) then timestamp = date_to_string (Time_restart) call atmos_model_restart(Atm, timestamp) call coupler_res(timestamp) Time_restart = Time_restart + Time_step_restart endif endif call print_memuse_stats('after full step') enddo !----------------------------------------------------------------------- #ifdef AVEC_TIMERS call avec_timers_output #endif call mpp_set_current_pelist() call mpp_clock_end(mainClock) call mpp_clock_begin(termClock) call coupler_end call mpp_set_current_pelist() call mpp_clock_end(termClock) call fms_end !----------------------------------------------------------------------- stop contains !####################################################################### subroutine coupler_init !----------------------------------------------------------------------- ! initialize all defined exchange grids and all boundary maps !----------------------------------------------------------------------- integer :: total_days, total_seconds, unit, ierr, io integer :: n, gnlon, gnlat integer :: date(6), flags type (time_type) :: Run_length character(len=9) :: month logical :: use_namelist logical, allocatable, dimension(:,:) :: mask real, allocatable, dimension(:,:) :: glon_bnd, glat_bnd integer :: omp_get_thread_num, get_cpu_affinity, base_cpu !----------------------------------------------------------------------- !----- initialization timing identifiers ---- !----- read namelist ------- !----- for backwards compatibilty read from file coupler.nml ----- #ifdef INTERNAL_FILE_NML read(input_nml_file, nml=coupler_nml, iostat=io) ierr = check_nml_error(io, 'coupler_nml') #else if (file_exist('input.nml')) then unit = open_namelist_file () else call error_mesg ('program coupler', & 'namelist file input.nml does not exist', FATAL) endif ierr=1 do while (ierr /= 0) read (unit, nml=coupler_nml, iostat=io, end=10) ierr = check_nml_error (io, 'coupler_nml') enddo 10 call close_file (unit) #endif !----- write namelist to logfile ----- call write_version_number (version, tag) if (mpp_pe() == mpp_root_pe()) write(stdlog(),nml=coupler_nml) !----- allocate and set the pelist (to the global pelist) ----- allocate( Atm%pelist (mpp_npes()) ) call mpp_get_current_pelist(Atm%pelist) !----- read restart file ----- if (file_exist('INPUT/coupler.res')) then call mpp_open( unit, 'INPUT/coupler.res', action=MPP_RDONLY ) read (unit,*,err=999) calendar_type read (unit,*) date_init read (unit,*) date goto 998 !back to fortran-4 ! read old-style coupler.res 999 call mpp_close (unit) call mpp_open (unit, 'INPUT/coupler.res', action=MPP_RDONLY, form=MPP_NATIVE) read (unit) calendar_type read (unit) date 998 call mpp_close(unit) else force_date_from_namelist = .true. endif !----- use namelist value (either no restart or override flag on) --- if ( force_date_from_namelist ) then if ( sum(current_date) <= 0 ) then call error_mesg ('program coupler', & 'no namelist value for current_date', FATAL) else date = current_date endif !----- override calendar type with namelist value ----- select case( uppercase(trim(calendar)) ) case( 'JULIAN' ) calendar_type = JULIAN case( 'NOLEAP' ) calendar_type = NOLEAP case( 'THIRTY_DAY' ) calendar_type = THIRTY_DAY_MONTHS case( 'NO_CALENDAR' ) calendar_type = NO_CALENDAR case default call mpp_error ( FATAL, 'COUPLER_MAIN: coupler_nml entry calendar must '// & 'be one of JULIAN|NOLEAP|THIRTY_DAY|NO_CALENDAR.' ) end select endif !$ base_cpu = get_cpu_affinity() !$ call omp_set_num_threads(atmos_nthreads) !$OMP PARALLEL NUM_THREADS(atmos_nthreads) !$ if(omp_get_thread_num() < atmos_nthreads/2 .OR. (.not. use_hyper_thread)) then !$ call set_cpu_affinity(base_cpu + omp_get_thread_num()) !$ else !$ call set_cpu_affinity(base_cpu + omp_get_thread_num() + & !$ ncores_per_node - atmos_nthreads/2) !$ endif !$ if (debug_affinity) then !$ write(6,*) mpp_pe()," atmos ",get_cpu_affinity(), base_cpu, omp_get_thread_num() !$ call flush(6) !$ endif !$OMP END PARALLEL call set_calendar_type (calendar_type) !----- write current/initial date actually used to logfile file ----- if ( mpp_pe() == mpp_root_pe() ) then write (stdlog(),16) date(1),trim(month_name(date(2))),date(3:6) endif 16 format (' current date used = ',i4,1x,a,2i3,2(':',i2.2),' gmt') !----------------------------------------------------------------------- !------ initialize diagnostics manager ------ call diag_manager_init (TIME_INIT=date) !----- always override initial/base date with diag_manager value ----- call get_base_date ( date_init(1), date_init(2), date_init(3), & date_init(4), date_init(5), date_init(6) ) !----- use current date if no base date ------ if ( date_init(1) == 0 ) date_init = date !----- set initial and current time types ------ Time_init = set_date (date_init(1), date_init(2), date_init(3), & date_init(4), date_init(5), date_init(6)) Time_atmos = set_date (date(1), date(2), date(3), & date(4), date(5), date(6)) !----------------------------------------------------------------------- !----- compute the ending time (compute days in each month first) ----- ! ! (NOTE: if run length in months then starting day must be <= 28) if ( months > 0 .and. date(3) > 28 ) & call error_mesg ('program coupler', & 'if run length in months then starting day must be <= 28', FATAL) Time_end = Time_atmos total_days = 0 do n = 1, months total_days = total_days + days_in_month(Time_end) Time_end = Time_atmos + set_time (0,total_days) enddo total_days = total_days + days total_seconds = hours*3600 + minutes*60 + seconds Run_length = set_time (total_seconds,total_days) Time_end = Time_atmos + Run_length !Need to pass Time_end into diag_manager for multiple thread case. call diag_manager_set_time_end(Time_end) !----------------------------------------------------------------------- !----- write time stamps (for start time and end time) ------ call mpp_open( unit, 'time_stamp.out', nohdrs=.TRUE. ) month = month_name(date(2)) if ( mpp_pe() == mpp_root_pe() ) write (unit,20) date, month(1:3) call get_date (Time_end, date(1), date(2), date(3), & date(4), date(5), date(6)) month = month_name(date(2)) if ( mpp_pe() == mpp_root_pe() ) write (unit,20) date, month(1:3) call mpp_close (unit) 20 format (6i4,2x,a3) !----------------------------------------------------------------------- !----- compute the time steps ------ Time_step_atmos = set_time (dt_atmos,0) Time_step_ocean = set_time (dt_ocean,0) num_cpld_calls = Run_length / Time_step_ocean num_atmos_calls = Time_step_ocean / Time_step_atmos Time_step_restart = set_time (restart_secs, restart_days) Time_restart = Time_atmos + Time_step_restart intrm_rst = .false. if (restart_days > 0 .or. restart_secs > 0) intrm_rst = .true. !----------------------------------------------------------------------- !------------------- some error checks --------------------------------- !----- initial time cannot be greater than current time ------- if ( Time_init > Time_atmos ) call error_mesg ('program coupler', & 'initial time is greater than current time', FATAL) !----- make sure run length is a multiple of ocean time step ------ if ( num_cpld_calls * Time_step_ocean /= Run_length ) & call error_mesg ('program coupler', & 'run length must be multiple of ocean time step', FATAL) ! ---- make sure cpld time step is a multiple of atmos time step ---- if ( num_atmos_calls * Time_step_atmos /= Time_step_ocean ) & call error_mesg ('program coupler', & 'atmos time step is not a multiple of the ocean time step', FATAL) !------ initialize component models ------ call atmos_model_init (Atm, Time_init, Time_atmos, Time_step_atmos) call print_memuse_stats('after atmos model init') call mpp_get_global_domain(Atm%Domain, xsize=gnlon, ysize=gnlat) allocate ( glon_bnd(gnlon+1,gnlat+1), glat_bnd(gnlon+1,gnlat+1) ) call mpp_global_field(Atm%Domain, Atm%lon_bnd, glon_bnd, position=CORNER) call mpp_global_field(Atm%Domain, Atm%lat_bnd, glat_bnd, position=CORNER) call data_override_init ( ) ! Atm_domain_in = Atm%domain, & ! Ice_domain_in = Ice%domain, & ! Land_domain_in = Land%domain ) !----------------------------------------------------------------------- !---- open and close dummy file in restart dir to check if dir exists -- if (mpp_pe() == 0 ) then call mpp_open( unit, 'RESTART/file' ) call mpp_close(unit, MPP_DELETE) endif !----------------------------------------------------------------------- end subroutine coupler_init !####################################################################### subroutine coupler_res(timestamp) character(len=32), intent(in) :: timestamp integer :: unit, date(6) !----- compute current date ------ call get_date (Time_atmos, date(1), date(2), date(3), & date(4), date(5), date(6)) !----- write restart file ------ if (mpp_pe() == mpp_root_pe())then call mpp_open( unit, 'RESTART/'//trim(timestamp)//'.coupler.res', nohdrs=.TRUE. ) write( unit, '(i6,8x,a)' )calendar_type, & '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' write( unit, '(6i6,8x,a)' )date_init, & 'Model start time: year, month, day, hour, minute, second' write( unit, '(6i6,8x,a)' )date, & 'Current model time: year, month, day, hour, minute, second' call mpp_close(unit) endif end subroutine coupler_res !####################################################################### subroutine coupler_end integer :: unit, date(6) !----------------------------------------------------------------------- call atmos_model_end (Atm) !----- compute current date ------ call get_date (Time_atmos, date(1), date(2), date(3), & date(4), date(5), date(6)) !----- check time versus expected ending time ---- if (Time_atmos /= Time_end) call error_mesg ('program coupler', & 'final time does not match expected ending time', WARNING) !----- write restart file ------ call mpp_open( unit, 'RESTART/coupler.res', nohdrs=.TRUE. ) if (mpp_pe() == mpp_root_pe())then write( unit, '(i6,8x,a)' )calendar_type, & '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' write( unit, '(6i6,8x,a)' )date_init, & 'Model start time: year, month, day, hour, minute, second' write( unit, '(6i6,8x,a)' )date, & 'Current model time: year, month, day, hour, minute, second' endif call mpp_close(unit) !----- final output of diagnostic fields ---- call diag_manager_end (Time_atmos) !----------------------------------------------------------------------- end subroutine coupler_end !####################################################################### end program coupler_main