MODULE module_wrf_top USE module_machine USE module_domain USE module_integrate USE module_driver_constants USE module_configure USE module_check_a_mundo USE module_timing USE module_wrf_error USE module_nesting USE module_dm, ONLY : wrf_dm_initialize,wrf_get_hostid,domain_active_this_task,mpi_comm_allcompute USE module_cpl, ONLY : coupler_on, cpl_finalize, cpl_defdomain USE module_xios, ONLY : xios_on, xios_finalizemodel, xios_initdomain IMPLICIT NONE REAL :: time INTEGER :: loop , & levels_to_process TYPE (domain) , POINTER :: keep_grid, grid_ptr, null_domain TYPE (domain) , pointer :: parent_grid, new_nest LOGICAL :: a_nest_was_opened TYPE (grid_config_rec_type), SAVE :: config_flags INTEGER :: kid, nestid INTEGER :: number_at_same_level INTEGER :: time_step_begin_restart INTEGER :: max_dom , domain_id , fid , oid , idum1 , idum2 , ierr INTEGER :: debug_level LOGICAL :: input_from_file INTEGER :: nbytes INTEGER, PARAMETER :: configbuflen = 4* 65536 INTEGER :: configbuf( configbuflen ) LOGICAL , EXTERNAL :: wrf_dm_on_monitor CHARACTER (LEN=256) :: rstname CHARACTER (LEN=80) :: message CHARACTER (LEN=256) , PRIVATE :: a_message INTERFACE SUBROUTINE Setup_Timekeeping( grid ) USE module_domain TYPE(domain), POINTER :: grid END SUBROUTINE Setup_Timekeeping SUBROUTINE wrf_dfi_write_initialized_state( ) END SUBROUTINE wrf_dfi_write_initialized_state SUBROUTINE wrf_dfi_startfwd_init( ) END SUBROUTINE wrf_dfi_startfwd_init SUBROUTINE wrf_dfi_startbck_init( ) END SUBROUTINE wrf_dfi_startbck_init SUBROUTINE wrf_dfi_bck_init( ) END SUBROUTINE wrf_dfi_bck_init SUBROUTINE wrf_dfi_fwd_init( ) END SUBROUTINE wrf_dfi_fwd_init SUBROUTINE wrf_dfi_fst_init( ) END SUBROUTINE wrf_dfi_fst_init SUBROUTINE wrf_dfi_array_reset ( ) END SUBROUTINE wrf_dfi_array_reset SUBROUTINE med_nest_initial ( parent , grid , config_flags ) USE module_domain USE module_configure TYPE (domain), POINTER :: grid , parent TYPE (grid_config_rec_type) config_flags END SUBROUTINE med_nest_initial END INTERFACE CONTAINS SUBROUTINE wrf_init( no_init1 ) LOGICAL, OPTIONAL, INTENT(IN) :: no_init1 INTEGER i, myproc, nproc, hostid, loccomm, ierr, buddcounter, mydevice, save_comm INTEGER, ALLOCATABLE :: hostids(:), budds(:) CHARACTER*512 hostname CHARACTER*512 mminlu_loc CHARACTER (LEN=*), PARAMETER :: release_version = 'V4.2.1' program_name = "WRF " // TRIM(release_version) // " MODEL" CALL init_modules(1) IF ( .NOT. PRESENT( no_init1 ) ) THEN CALL WRFU_Initialize( defaultCalKind=WRFU_CAL_GREGORIAN ) ENDIF CALL init_modules(2) CALL wrf_get_dm_communicator( save_comm ) CALL wrf_set_dm_communicator( mpi_comm_allcompute ) IF ( wrf_dm_on_monitor() ) THEN CALL initial_config ENDIF CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) CALL wrf_dm_bcast_bytes( configbuf, nbytes ) CALL set_config_as_buffer( configbuf, configbuflen ) CALL wrf_dm_initialize CALL wrf_set_dm_communicator( save_comm ) CALL setup_physics_suite CALL set_derived_rconfigs CALL check_nml_consistency CALL set_physics_rconfigs CALL nl_get_debug_level ( 1, debug_level ) CALL set_wrf_debug_level ( debug_level ) NULLIFY( null_domain ) CALL nl_get_max_dom( 1, max_dom ) IF ( max_dom > 1 ) THEN END IF CALL wrf_message ( program_name ) CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain ' ) CALL alloc_and_configure_domain ( domain_id = 1 , & active_this_task = domain_active_this_task(1), & grid = head_grid , & parent = null_domain , & kid = -1 ) CALL wrf_debug ( 100 , 'wrf: calling model_to_grid_config_rec ' ) CALL model_to_grid_config_rec ( head_grid%id , model_config_rec , config_flags ) CALL wrf_debug ( 100 , 'wrf: calling set_scalar_indices_from_config ' ) CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) CALL wrf_debug ( 100 , 'wrf: calling init_wrfio' ) CALL init_wrfio CALL wrf_get_dm_communicator( save_comm ) CALL wrf_set_dm_communicator( mpi_comm_allcompute ) CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) CALL wrf_dm_bcast_bytes( configbuf, nbytes ) CALL set_config_as_buffer( configbuf, configbuflen ) CALL wrf_set_dm_communicator( save_comm ) IF ( head_grid%dfi_opt .NE. DFI_NODFI ) head_grid%dfi_stage = DFI_SETUP CALL Setup_Timekeeping (head_grid) IF ( domain_active_this_task(1) ) THEN CALL med_initialdata_input( head_grid , config_flags ) IF ( config_flags%write_restart_at_0h ) THEN CALL med_restart_out ( head_grid, config_flags ) CALL wrf_debug ( 0 , ' 0 h restart only wrf: SUCCESS COMPLETE WRF' ) CALL wrf_finalize( ) END IF ENDIF head_grid%start_subtime = domain_get_start_time ( head_grid ) head_grid%stop_subtime = domain_get_stop_time ( head_grid ) IF ( domain_active_this_task(1) ) THEN IF ( head_grid%dfi_opt .NE. DFI_NODFI ) THEN CALL alloc_doms_for_dfi ( head_grid ) END IF IF (coupler_on) CALL cpl_defdomain( head_grid ) IF ( xios_on) CALL xios_initdomain( head_grid, config_flags ) ENDIF END SUBROUTINE wrf_init SUBROUTINE wrf_run( ) CALL wrf_debug ( 100 , 'wrf: calling integrate' ) CALL integrate ( head_grid ) CALL wrf_debug ( 100 , 'wrf: back from integrate' ) END SUBROUTINE wrf_run SUBROUTINE wrf_finalize( no_shutdown ) LOGICAL, OPTIONAL, INTENT(IN) :: no_shutdown CALL med_shutdown_io ( head_grid , config_flags ) CALL wrf_debug ( 100 , 'wrf: back from med_shutdown_io' ) CALL wrf_debug ( 0 , 'wrf: SUCCESS COMPLETE WRF' ) IF ( .NOT. PRESENT( no_shutdown ) ) THEN IF (xios_on) THEN CALL xios_finalizemodel() IF (coupler_on) CALL cpl_finalize() ELSE CALL WRFU_Finalize CALL wrf_shutdown ENDIF ENDIF END SUBROUTINE wrf_finalize SUBROUTINE wrf_dfi() IMPLICIT NONE IF ( config_flags%dfi_opt .NE. DFI_NODFI ) THEN SELECT CASE ( config_flags%dfi_opt ) CASE (DFI_DFL) wrf_err_message = 'Initializing with DFL' CALL wrf_message(TRIM(wrf_err_message)) wrf_err_message = ' Filtering forward in time' CALL wrf_message(TRIM(wrf_err_message)) CALL wrf_dfi_fwd_init() CALL wrf_run() CALL wrf_dfi_array_reset() CALL wrf_dfi_fst_init() IF ( config_flags%dfi_write_filtered_input ) THEN CALL wrf_dfi_write_initialized_state() END IF CASE (DFI_DDFI) wrf_err_message = 'Initializing with DDFI' CALL wrf_message(TRIM(wrf_err_message)) wrf_err_message = ' Integrating backward in time' CALL wrf_message(TRIM(wrf_err_message)) CALL wrf_dfi_bck_init() CALL wrf_run() wrf_err_message = ' Filtering forward in time' CALL wrf_message(TRIM(wrf_err_message)) CALL wrf_dfi_fwd_init() CALL wrf_run() CALL wrf_dfi_array_reset() CALL wrf_dfi_fst_init() IF ( config_flags%dfi_write_filtered_input ) THEN CALL wrf_dfi_write_initialized_state() END IF CASE (DFI_TDFI) wrf_err_message = 'Initializing with TDFI' CALL wrf_message(TRIM(wrf_err_message)) wrf_err_message = ' Integrating backward in time' CALL wrf_message(TRIM(wrf_err_message)) CALL wrf_dfi_bck_init() CALL wrf_run() CALL wrf_dfi_array_reset() wrf_err_message = ' Filtering forward in time' CALL wrf_message(TRIM(wrf_err_message)) CALL wrf_dfi_fwd_init() CALL wrf_run() CALL wrf_dfi_array_reset() CALL wrf_dfi_fst_init() IF ( config_flags%dfi_write_filtered_input ) THEN CALL wrf_dfi_write_initialized_state() END IF CASE DEFAULT wrf_err_message = 'Unrecognized DFI_OPT in namelist' CALL wrf_error_fatal3("",457,& TRIM(wrf_err_message)) END SELECT END IF END SUBROUTINE wrf_dfi SUBROUTINE set_derived_rconfigs IMPLICIT NONE INTEGER :: i IF ( model_config_rec % dfi_opt .EQ. DFI_NODFI ) THEN DO i = 1, model_config_rec % max_dom model_config_rec % mp_physics_dfi(i) = -1 ENDDO ELSE DO i = 1, model_config_rec % max_dom model_config_rec % mp_physics_dfi(i) = model_config_rec % mp_physics(i) ENDDO END IF IF ( model_config_rec % dfi_opt .EQ. DFI_NODFI ) THEN DO i = 1, model_config_rec % max_dom model_config_rec % bl_pbl_physics_dfi(i) = -1 ENDDO ELSE DO i = 1, model_config_rec % max_dom model_config_rec % bl_pbl_physics_dfi(i) = model_config_rec % bl_pbl_physics(i) ENDDO END IF END SUBROUTINE set_derived_rconfigs RECURSIVE SUBROUTINE alloc_doms_for_dfi ( grid ) TYPE (domain) , pointer :: grid TYPE (domain) , pointer :: new_nest_loc TYPE (grid_config_rec_type) :: parent_config_flags INTEGER :: nestid_loc , kid_loc DO WHILE ( nests_to_open( grid , nestid_loc , kid_loc ) ) CALL alloc_and_configure_domain ( domain_id = nestid_loc , & grid = new_nest_loc , & parent = grid , & kid = kid_loc ) print *,'for parent domain id #',grid%id,', found child domain #',nestid_loc new_nest_loc%dfi_opt = head_grid%dfi_opt new_nest_loc%dfi_stage = DFI_SETUP CALL Setup_Timekeeping (new_nest_loc) CALL model_to_grid_config_rec ( grid%id , model_config_rec , parent_config_flags ) CALL med_nest_initial ( grid , new_nest_loc , config_flags ) CALL alloc_doms_for_dfi ( new_nest_loc ) END DO END SUBROUTINE alloc_doms_for_dfi END MODULE module_wrf_top