!WRF:PACKAGE:IO ! MODULE module_io_wrf USE module_wrf_error USE module_date_time ! switch parameters INTEGER, PARAMETER :: model_input_only=1 INTEGER, PARAMETER :: aux_model_input1_only=2 INTEGER, PARAMETER :: aux_model_input2_only=3 INTEGER, PARAMETER :: aux_model_input3_only=4 INTEGER, PARAMETER :: aux_model_input4_only=5 INTEGER, PARAMETER :: aux_model_input5_only=6 INTEGER, PARAMETER :: history_only=7 INTEGER, PARAMETER :: aux_hist1_only=8 INTEGER, PARAMETER :: aux_hist2_only=9 INTEGER, PARAMETER :: aux_hist3_only=10 INTEGER, PARAMETER :: aux_hist4_only=11 INTEGER, PARAMETER :: aux_hist5_only=12 INTEGER, PARAMETER :: boundary_only=13, restart_only=14 CONTAINS SUBROUTINE init_module_io_wrf END SUBROUTINE init_module_io_wrf END MODULE module_io_wrf ! ------------ Output model input data sets SUBROUTINE output_model_input_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , model_input_only , ierr ) RETURN END SUBROUTINE output_model_input_wrf SUBROUTINE output_aux_model_input1_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_model_input1_only , ierr ) RETURN END SUBROUTINE output_aux_model_input1_wrf SUBROUTINE output_aux_model_input2_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_model_input2_only , ierr ) RETURN END SUBROUTINE output_aux_model_input2_wrf SUBROUTINE output_aux_model_input3_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_model_input3_only , ierr ) RETURN END SUBROUTINE output_aux_model_input3_wrf SUBROUTINE output_aux_model_input4_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_model_input4_only , ierr ) RETURN END SUBROUTINE output_aux_model_input4_wrf SUBROUTINE output_aux_model_input5_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_model_input5_only , ierr ) RETURN END SUBROUTINE output_aux_model_input5_wrf ! ------------ Output model history data sets SUBROUTINE output_history_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , history_only , ierr ) RETURN END SUBROUTINE output_history_wrf SUBROUTINE output_aux_hist1_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_hist1_only , ierr ) RETURN END SUBROUTINE output_aux_hist1_wrf SUBROUTINE output_aux_hist2_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_hist2_only , ierr ) RETURN END SUBROUTINE output_aux_hist2_wrf SUBROUTINE output_aux_hist3_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_hist3_only , ierr ) RETURN END SUBROUTINE output_aux_hist3_wrf SUBROUTINE output_aux_hist4_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_hist4_only , ierr ) RETURN END SUBROUTINE output_aux_hist4_wrf SUBROUTINE output_aux_hist5_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , aux_hist5_only , ierr ) RETURN END SUBROUTINE output_aux_hist5_wrf ! ------------ Output model restart data sets SUBROUTINE output_restart_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , restart_only , ierr ) RETURN END SUBROUTINE output_restart_wrf ! ------------ Output model boundary data sets SUBROUTINE output_boundary_wrf ( fid , grid , config_flags , ierr ) USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL output_wrf ( fid , grid , config_flags , boundary_only , ierr ) RETURN END SUBROUTINE output_boundary_wrf ! ------------ principal wrf output routine (called by above) SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) USE module_io USE module_wrf_error USE module_io_wrf USE module_domain USE module_state_description USE module_configure USE module_date_time IMPLICIT NONE #include #include TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid, switch INTEGER, INTENT(INOUT) :: ierr ! Local data INTEGER ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe INTEGER , DIMENSION(3) :: domain_start , domain_end INTEGER , DIMENSION(3) :: memory_start , memory_end INTEGER , DIMENSION(3) :: patch_start , patch_end INTEGER i,j INTEGER ny , nm , nd , nh , ni , ns , nt INTEGER julyr, julday, idt, iswater , map_proj INTEGER filestate LOGICAL dryrun REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 INTEGER dyn_opt, diff_opt, km_opt, damp_opt, & mp_physics, ra_lw_physics, ra_sw_physics, bl_sfclay_physics, & bl_surface_physics, bl_pbl_physics, cu_physics REAL khdif, kvdif CHARACTER*256 message CHARACTER*80 fname CHARACTER*80 char_junk INTEGER ibuf(1) REAL rbuf(1) CALL wrf_inquire_filename ( fid , fname , filestate , ierr ) IF ( ierr /= 0 ) THEN WRITE(wrf_err_message,*)'module_io_wrf: output_wrf: wrf_inquire_filename Status = ',ierr CALL wrf_error_fatal( wrf_err_message ) ENDIF dryrun = ( filestate /= WRF_FILE_OPENED_AND_COMMITTED ) WRITE(wrf_err_message,*)'output_wrf: dryrun = ',dryrun CALL wrf_debug( 500 , wrf_err_message ) WRITE(wrf_err_message,*)'output_wrf: write_metadata = ',grid%write_metadata CALL wrf_debug( 500 , wrf_err_message ) CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) call get_dyn_opt ( dyn_opt ) call get_diff_opt ( diff_opt ) call get_km_opt ( km_opt ) call get_damp_opt ( damp_opt ) call get_khdif ( grid%id, khdif ) call get_kvdif ( grid%id, kvdif ) call get_mp_physics ( grid%id, mp_physics ) call get_ra_lw_physics ( grid%id, ra_lw_physics ) call get_ra_sw_physics ( grid%id, ra_sw_physics ) call get_bl_sfclay_physics ( grid%id, bl_sfclay_physics ) call get_bl_surface_physics ( grid%id, bl_surface_physics ) call get_bl_pbl_physics ( grid%id, bl_pbl_physics ) call get_cu_physics ( grid%id, cu_physics ) ! julday and gmt can be set in namelist_03 for ideal.exe run CALL get_gmt (grid%id, gmt) CALL get_julyr (grid%id, julyr) CALL get_julday (grid%id, julday) CALL get_mminlu ( char_junk(1:4) ) CALL get_iswater (grid%id, iswater ) CALL get_cen_lat ( grid%id , cen_lat ) CALL get_cen_lon ( grid%id , cen_lon ) IF ( switch .EQ. boundary_only ) THEN CALL get_bdyfrq ( grid%id , bdyfrq ) ENDIF CALL get_truelat1 ( grid%id , truelat1 ) CALL get_truelat2 ( grid%id , truelat2 ) CALL get_map_proj ( grid%id , map_proj ) WRITE ( wrf_err_message , * ) 'module_io_wrf: output_wrf: current_date=',current_date CALL wrf_debug ( 100 , wrf_err_message ) IF ( .NOT. dryrun .AND. grid%write_metadata ) THEN WRITE( message , * ) "OUTPUT FROM " , TRIM(program_name) CALL wrf_put_dom_ti_char ( fid , 'TITLE' , TRIM(message) , ierr ) CALL wrf_put_dom_ti_char ( fid , 'START_DATE', TRIM(start_date) , ierr ) ibuf(1) = config_flags%e_we - config_flags%s_we + 1 CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_GRID_DIMENSION' , ibuf , 1 , ierr ) ibuf(1) = config_flags%e_sn - config_flags%s_sn + 1 CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_GRID_DIMENSION' , ibuf , 1 , ierr ) ibuf(1) = config_flags%e_vert - config_flags%s_vert CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' , ibuf , 1 , ierr ) ! added these fields for W. Skamarock, 020402, JM ibuf(1) = dyn_opt CALL wrf_put_dom_ti_integer ( fid , 'DYN_OPT' , ibuf , 1 , ierr ) ibuf(1) = diff_opt CALL wrf_put_dom_ti_integer ( fid , 'DIFF_OPT' , ibuf , 1 , ierr ) ibuf(1) = km_opt CALL wrf_put_dom_ti_integer ( fid , 'KM_OPT' , ibuf , 1 , ierr ) ibuf(1) = damp_opt CALL wrf_put_dom_ti_integer ( fid , 'DAMP_OPT' , ibuf , 1 , ierr ) rbuf(1) = khdif CALL wrf_put_dom_ti_real ( fid , 'KHDIF' , rbuf , 1 , ierr ) rbuf(1) = kvdif CALL wrf_put_dom_ti_real ( fid , 'KVDIF' , rbuf , 1 , ierr ) ibuf(1) = mp_physics CALL wrf_put_dom_ti_integer ( fid , 'MP_PHYSICS' , ibuf , 1 , ierr ) ibuf(1) = ra_lw_physics CALL wrf_put_dom_ti_integer ( fid , 'RA_LW_PHYSICS' , ibuf , 1 , ierr ) ibuf(1) = ra_sw_physics CALL wrf_put_dom_ti_integer ( fid , 'RA_SW_PHYSICS' , ibuf , 1 , ierr ) ibuf(1) = bl_sfclay_physics CALL wrf_put_dom_ti_integer ( fid , 'BL_SFCLAY_PHYSICS' , ibuf , 1 , ierr ) ibuf(1) = bl_surface_physics CALL wrf_put_dom_ti_integer ( fid , 'BL_SURFACE_PHYSICS' , ibuf , 1 , ierr ) ibuf(1) = bl_pbl_physics CALL wrf_put_dom_ti_integer ( fid , 'BL_PBL_PHYSICS' , ibuf , 1 , ierr ) ibuf(1) = cu_physics CALL wrf_put_dom_ti_integer ( fid , 'CU_PHYSICS' , ibuf , 1 , ierr ) ! added these fields for use by reassembly programs , 010831, JM ibuf(1) = MAX(ips,ids) CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_START_UNSTAG' , ibuf , 1 , ierr ) ibuf(1) = MIN(ipe,ide-1) CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_END_UNSTAG' , ibuf , 1 , ierr ) ibuf(1) = MAX(ips,ids) CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_START_STAG' , ibuf , 1 , ierr ) ibuf(1) = MIN(ipe,ide) CALL wrf_put_dom_ti_integer ( fid , 'WEST-EAST_PATCH_END_STAG' , ibuf , 1 , ierr ) ibuf(1) = MAX(jps,jds) CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_START_UNSTAG' , ibuf , 1 , ierr ) ibuf(1) = MIN(jpe,jde-1) CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_END_UNSTAG' , ibuf , 1 , ierr ) ibuf(1) = MAX(jps,jds) CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_START_STAG' , ibuf , 1 , ierr ) ibuf(1) = MIN(jpe,jde) CALL wrf_put_dom_ti_integer ( fid , 'SOUTH-NORTH_PATCH_END_STAG' , ibuf , 1 , ierr ) ibuf(1) = MAX(kps,kds) CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_START_UNSTAG' , ibuf , 1 , ierr ) ibuf(1) = MIN(kpe,kde-1) CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_END_UNSTAG' , ibuf , 1 , ierr ) ibuf(1) = MAX(kps,kds) CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_START_STAG' , ibuf , 1 , ierr ) ibuf(1) = MIN(kpe,kde) CALL wrf_put_dom_ti_integer ( fid , 'BOTTOM-TOP_PATCH_END_STAG' , ibuf , 1 , ierr ) ! end add 010831 JM CALL wrf_put_dom_ti_real ( fid , 'DX' , config_flags%dx , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'DY' , config_flags%dy , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'DT' , config_flags%dt , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'TRUELAT1', config_flags%truelat1, 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'TRUELAT2', config_flags%truelat2, 1 , ierr ) CALL wrf_put_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , ierr ) CALL wrf_put_dom_ti_char ( fid , 'MMINLU', mminlu(1:4) , ierr ) IF ( switch .EQ. boundary_only ) THEN CALL wrf_put_dom_ti_real ( fid , 'BDYFRQ' , config_flags%bdyfrq , 1 , ierr ) ENDIF CALL split_date_char ( start_date , ny , nm , nd , nh , ni , ns , nt ) ENDIF IF ( switch .EQ. model_input_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_inputout.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_model_input1_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput1out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_model_input2_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput2out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_model_input3_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput3out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_model_input4_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput4out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_model_input5_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxinput5out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. history_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_histout.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_hist1_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist1out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_hist2_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist2out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_hist3_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist3out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_hist1_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist1out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_hist1_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist4out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. aux_hist5_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_auxhist5out.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. restart_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_restartout.inc' ) ! generated by the registry #include ELSE IF ( switch .EQ. boundary_only ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling code in wrf_bdyout.inc' ) ! generated by the registry #include ENDIF IF ( .NOT. dryrun ) THEN CALL wrf_debug ( 300 , 'output_wrf: calling wrf_iosync ' ) CALL wrf_iosync ( fid , ierr ) CALL wrf_debug ( 300 , 'output_wrf: back from wrf_iosync ' ) ENDIF CALL wrf_debug ( 300 , 'output_wrf: returning from ' ) RETURN END SUBROUTINE output_wrf #if 1 ! ------------ Input model input data sets SUBROUTINE input_model_input_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , model_input_only , ierr ) RETURN END SUBROUTINE input_model_input_wrf SUBROUTINE input_aux_model_input1_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_model_input1_only , ierr ) RETURN END SUBROUTINE input_aux_model_input1_wrf SUBROUTINE input_aux_model_input2_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_model_input2_only , ierr ) RETURN END SUBROUTINE input_aux_model_input2_wrf SUBROUTINE input_aux_model_input3_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_model_input3_only , ierr ) RETURN END SUBROUTINE input_aux_model_input3_wrf SUBROUTINE input_aux_model_input4_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_model_input4_only , ierr ) RETURN END SUBROUTINE input_aux_model_input4_wrf SUBROUTINE input_aux_model_input5_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_model_input5_only , ierr ) RETURN END SUBROUTINE input_aux_model_input5_wrf ! ------------ Input model history data sets SUBROUTINE input_history_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , history_only , ierr ) RETURN END SUBROUTINE input_history_wrf SUBROUTINE input_aux_hist1_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_hist1_only , ierr ) RETURN END SUBROUTINE input_aux_hist1_wrf SUBROUTINE input_aux_hist2_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_hist2_only , ierr ) RETURN END SUBROUTINE input_aux_hist2_wrf SUBROUTINE input_aux_hist3_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_hist3_only , ierr ) RETURN END SUBROUTINE input_aux_hist3_wrf SUBROUTINE input_aux_hist4_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_hist4_only , ierr ) RETURN END SUBROUTINE input_aux_hist4_wrf SUBROUTINE input_aux_hist5_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , aux_hist5_only , ierr ) RETURN END SUBROUTINE input_aux_hist5_wrf ! ------------ Input model restart data sets SUBROUTINE input_restart_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , restart_only , ierr ) RETURN END SUBROUTINE input_restart_wrf ! ------------ Input model boundary data sets SUBROUTINE input_boundary_wrf ( fid , grid , config_flags , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io_wrf IMPLICIT NONE TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(INOUT) :: ierr CALL input_wrf ( fid , grid , config_flags , boundary_only , ierr ) RETURN END SUBROUTINE input_boundary_wrf ! ------------ Principal model input routine (called by above) SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) USE module_domain USE module_state_description USE module_configure USE module_io USE module_io_wrf USE module_date_time USE module_bc_time_utilities IMPLICIT NONE #include #include TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid INTEGER, INTENT(IN) :: switch INTEGER, INTENT(INOUT) :: ierr ! Local data INTEGER ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe INTEGER iname(9) INTEGER iordering(3) INTEGER icurrent_date(24) INTEGER i,j,k INTEGER icnt INTEGER ndim INTEGER ilen INTEGER , DIMENSION(3) :: domain_start , domain_end INTEGER , DIMENSION(3) :: memory_start , memory_end INTEGER , DIMENSION(3) :: patch_start , patch_end CHARACTER*256 errmess CHARACTER*9 NAMESTR INTEGER IBDY, NAMELEN LOGICAL wrf_dm_on_monitor EXTERNAL wrf_dm_on_monitor REAL time, oldtime, newtime CHARACTER*19 new_date CHARACTER*24 base_date INTEGER ny , nm , nd , nh , ni , ns , nt INTEGER idt INTEGER itmp, dyn_opt ierr = 0 CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) ! added 020402 for W. Skamarock. JM CALL get_dyn_opt( dyn_opt ) CALL wrf_get_dom_ti_integer ( fid, 'DYN_OPT', itmp, 1, icnt, ierr ) IF ( itmp .NE. dyn_opt ) THEN WRITE(wrf_err_message,*)'input_wrf: dyn_opt in file ',itmp,' NE namelist ',dyn_opt CALL wrf_error_fatal( wrf_err_message ) ENDIF CALL wrf_get_dom_ti_real ( fid , 'CEN_LAT' , config_flags%cen_lat , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LAT returns ',config_flags%cen_lat CALL wrf_debug ( 300 , wrf_err_message ) CALL set_cen_lat ( grid%id , config_flags%cen_lat ) CALL wrf_get_dom_ti_real ( fid , 'CEN_LON' , config_flags%cen_lon , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for CEN_LON returns ',config_flags%cen_lon CALL wrf_debug ( 300 , wrf_err_message ) CALL set_cen_lon ( grid%id , config_flags%cen_lon ) CALL wrf_get_dom_ti_real ( fid , 'TRUELAT1' , config_flags%truelat1 , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT1 returns ',config_flags%truelat1 CALL wrf_debug ( 300 , wrf_err_message ) CALL set_truelat1 ( grid%id , config_flags%truelat1 ) CALL wrf_get_dom_ti_real ( fid , 'TRUELAT2' , config_flags%truelat2 , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for TRUELAT2 returns ',config_flags%truelat2 CALL wrf_debug ( 300 , wrf_err_message ) CALL set_truelat2 ( grid%id , config_flags%truelat2 ) IF ( switch .NE. boundary_only ) THEN CALL wrf_get_dom_ti_real ( fid , 'GMT' , config_flags%gmt , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for GMT returns ',config_flags%gmt CALL wrf_debug ( 300 , wrf_err_message ) CALL set_gmt ( grid%id , config_flags%gmt ) CALL wrf_get_dom_ti_integer ( fid , 'JULYR' , config_flags%julyr , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULYR returns ',config_flags%julyr CALL wrf_debug ( 300 , wrf_err_message ) CALL set_julyr ( grid%id , config_flags%julyr ) CALL wrf_get_dom_ti_integer ( fid , 'JULDAY' , config_flags%julday , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for JULDAY returns ',config_flags%julday CALL wrf_debug ( 300 , wrf_err_message ) CALL set_julday ( grid%id , config_flags%julday ) ENDIF CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' , config_flags%iswater , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISWATER returns ',config_flags%iswater CALL wrf_debug ( 300 , wrf_err_message ) CALL set_iswater ( grid%id , config_flags%iswater ) CALL wrf_get_dom_ti_integer ( fid , 'MAP_PROJ' , config_flags%map_proj , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for MAP_PROJ returns ',config_flags%map_proj CALL wrf_debug ( 300 , wrf_err_message ) CALL set_map_proj ( grid%id , config_flags%map_proj ) CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_char for MMINLU returns ',mminlu(1:4) CALL wrf_debug ( 300 , wrf_err_message ) CALL set_mminlu ( mminlu(1:4) ) IF ( switch .EQ. boundary_only ) THEN CALL wrf_get_dom_ti_real ( fid , 'BDYFRQ' , config_flags%bdyfrq , 1 , icnt , ierr ) WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_real for BDYFRQ returns ',config_flags%bdyfrq,ierr CALL wrf_debug ( 300 , wrf_err_message ) CALL set_bdyfrq ( grid%id , config_flags%bdyfrq ) CALL get_time_to_read_again ( oldtime ) newtime = oldtime + config_flags%bdyfrq CALL set_time_to_read_again ( newtime ) ENDIF ! ! This call to wrf_get_next_time will position the dataset over the next time-frame ! in the file and return the current_date, which is used as an argument to the ! read_field routines in the blocks of code included below. Note that we read the ! next time *after* all the meta data has been read. This is only important for the ! WRF internal I/O format because it is order-dependent. Other formats shouldn't care ! about this. ! CALL wrf_get_next_time(fid, current_date , ierr) WRITE(wrf_err_message,*)fid,' input_wrf: wrf_get_next_time current_date: ',current_date(1:19),' Status = ',ierr CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) IF ( switch .EQ. model_input_only ) THEN #include ELSE IF ( switch .EQ. history_only ) THEN #include # ifndef ONLY_WRFMODEL_IO ELSE IF ( switch .EQ. aux_model_input1_only ) THEN #include ELSE IF ( switch .EQ. aux_model_input2_only ) THEN #include ELSE IF ( switch .EQ. aux_model_input3_only ) THEN #include ELSE IF ( switch .EQ. aux_model_input4_only ) THEN #include ELSE IF ( switch .EQ. aux_model_input5_only ) THEN #include ELSE IF ( switch .EQ. aux_hist1_only ) THEN #include ELSE IF ( switch .EQ. aux_hist2_only ) THEN #include ELSE IF ( switch .EQ. aux_hist3_only ) THEN #include ELSE IF ( switch .EQ. aux_hist4_only ) THEN #include ELSE IF ( switch .EQ. aux_hist5_only ) THEN #include # endif ELSE IF ( switch .EQ. restart_only ) THEN #include ELSE IF ( switch .EQ. boundary_only ) THEN #include ENDIF RETURN END SUBROUTINE input_wrf #endif SUBROUTINE debug_io_wrf ( msg , date, ds , de , ps , pe , ms , me ) USE module_wrf_error IMPLICIT NONE CHARACTER*(*) :: msg , date INTEGER , DIMENSION(3) , INTENT(IN) :: ds , de , ps , pe , ms , me IF ( wrf_at_debug_level(300) ) THEN CALL wrf_message ( msg ) WRITE(wrf_err_message,*)'date ',date ; CALL wrf_message ( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'ds ',ds ; CALL wrf_message ( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'de ',de ; CALL wrf_message ( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'ps ',ps ; CALL wrf_message ( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'pe ',pe ; CALL wrf_message ( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'ms ',ms ; CALL wrf_message ( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'me ',me ; CALL wrf_message ( TRIM(wrf_err_message) ) ENDIF RETURN END SUBROUTINE debug_io_wrf SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & DomainDesc, & bdy_mask , & dryrun , & MemoryOrder, & Stagger, & Dimname1, Dimname2, Dimname3 , & Desc, Units, & debug_message , & ds1, de1, ds2, de2, ds3, de3, & ms1, me1, ms2, me2, ms3, me3, & ps1, pe1, ps2, pe2, ps3, pe3, Status ) USE module_io USE module_wrf_error USE module_state_description USE module_timing IMPLICIT NONE integer :: DataHandle character*(*) :: DateStr character*(*) :: Var integer :: Field(*) integer :: FieldType integer :: Comm integer :: IOComm integer :: DomainDesc logical :: dryrun character*(*) :: MemoryOrder logical, dimension(4) :: bdy_mask character*(*) :: Stagger character*(*) :: Dimname1, Dimname2, Dimname3 character*(*) :: Desc, Units character*(*) :: debug_message INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & ms1, me1, ms2, me2, ms3, me3, & ps1, pe1, ps2, pe2, ps3, pe3 INTEGER , DIMENSION(3) :: domain_start , domain_end INTEGER , DIMENSION(3) :: memory_start , memory_end INTEGER , DIMENSION(3) :: patch_start , patch_end CHARACTER*80 , DIMENSION(3) :: dimnames integer ,intent(inout) :: Status LOGICAL for_out INTEGER Hndl, io_form IF ( wrf_at_debug_level( 500 ) ) THEN call start_timing ENDIF domain_start(1) = ds1 ; domain_end(1) = de1 ; patch_start(1) = ps1 ; patch_end(1) = pe1 ; memory_start(1) = ms1 ; memory_end(1) = me1 ; domain_start(2) = ds2 ; domain_end(2) = de2 ; patch_start(2) = ps2 ; patch_end(2) = pe2 ; memory_start(2) = ms2 ; memory_end(2) = me2 ; domain_start(3) = ds3 ; domain_end(3) = de3 ; patch_start(3) = ps3 ; patch_end(3) = pe3 ; memory_start(3) = ms3 ; memory_end(3) = me3 ; dimnames(1) = Dimname1 dimnames(2) = Dimname2 dimnames(3) = Dimname3 CALL debug_io_wrf ( debug_message,DateStr, & domain_start,domain_end,patch_start,patch_end, & memory_start,memory_end ) Status = 1 if ( de1 - ds1 < 0 ) return if ( de2 - ds2 < 0 ) return if ( de3 - ds3 < 0 ) return if ( pe1 - ps1 < 0 ) return if ( pe2 - ps2 < 0 ) return if ( pe3 - ps3 < 0 ) return if ( me1 - ms1 < 0 ) return if ( me2 - ms2 < 0 ) return if ( me3 - ms3 < 0 ) return Status = 0 CALL wrf_write_field ( & DataHandle & ! DataHandle ,DateStr & ! DateStr ,Var & ! Data Name ,Field & ! Field ,FieldType & ! FieldType ,Comm & ! Comm ,IOComm & ! IOComm ,DomainDesc & ! DomainDesc ,bdy_mask & ! bdy_mask ,MemoryOrder & ! MemoryOrder ,Stagger & ! JMMODS 010620 ,dimnames & ! JMMODS 001109 ,domain_start & ! DomainStart ,domain_end & ! DomainEnd ,memory_start & ! MemoryStart ,memory_end & ! MemoryEnd ,patch_start & ! PatchStart ,patch_end & ! PatchEnd ,Status ) CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( dryrun .and. io_form .EQ. IO_NETCDF) THEN CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"description" & ! Element ,Var & ! Data Name ,Desc & ! Data ,Status ) CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"units" & ! Element ,Var & ! Data Name ,Units & ! Data ,Status ) CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"stagger" & ! Element ,Var & ! Data Name ,Stagger & ! Data ,Status ) ENDIF IF (io_form .EQ. IO_HDF5) THEN CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"description" & ! Element ,Var & ! Data Name ,Desc & ! Data ,Status ) CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"units" & ! Element ,Var & ! Data Name ,Units & ! Data ,Status ) CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"stagger" & ! Element ,Var & ! Data Name ,Stagger & ! Data ,Status ) ENDIF IF (io_form .EQ. IO_PHDF5) THEN CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"description" & ! Element ,Var & ! Data Name ,Desc & ! Data ,Status ) CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"units" & ! Element ,Var & ! Data Name ,Units & ! Data ,Status ) CALL wrf_put_var_ti_char( & DataHandle & ! DataHandle ,"stagger" & ! Element ,Var & ! Data Name ,Stagger & ! Data ,Status ) ENDIF IF ( wrf_at_debug_level(300) ) THEN WRITE(wrf_err_message,*) debug_message,' Status = ',Status CALL wrf_message ( TRIM(wrf_err_message) ) ENDIF IF ( wrf_at_debug_level( 500 ) ) THEN CALL end_timing('wrf_ext_write_field') ENDIF END SUBROUTINE wrf_ext_write_field SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & DomainDesc, bdy_mask, MemoryOrder,Stagger, & debug_message , & ds1, de1, ds2, de2, ds3, de3, & ms1, me1, ms2, me2, ms3, me3, & ps1, pe1, ps2, pe2, ps3, pe3, Status ) USE module_io USE module_wrf_error IMPLICIT NONE integer :: DataHandle character*(*) :: DateStr character*(*) :: Var integer :: Field(*) integer :: FieldType integer :: Comm integer :: IOComm integer :: DomainDesc logical, dimension(4) :: bdy_mask character*(*) :: MemoryOrder character*(*) :: Stagger character*(*) :: debug_message INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, & ms1, me1, ms2, me2, ms3, me3, & ps1, pe1, ps2, pe2, ps3, pe3 INTEGER , DIMENSION(3) :: domain_start , domain_end INTEGER , DIMENSION(3) :: memory_start , memory_end INTEGER , DIMENSION(3) :: patch_start , patch_end CHARACTER*80 , DIMENSION(3) :: dimnames integer ,intent(inout) :: Status domain_start(1) = ds1 ; domain_end(1) = de1 ; patch_start(1) = ps1 ; patch_end(1) = pe1 ; memory_start(1) = ms1 ; memory_end(1) = me1 ; domain_start(2) = ds2 ; domain_end(2) = de2 ; patch_start(2) = ps2 ; patch_end(2) = pe2 ; memory_start(2) = ms2 ; memory_end(2) = me2 ; domain_start(3) = ds3 ; domain_end(3) = de3 ; patch_start(3) = ps3 ; patch_end(3) = pe3 ; memory_start(3) = ms3 ; memory_end(3) = me3 ; CALL debug_io_wrf ( debug_message,DateStr, & domain_start,domain_end,patch_start,patch_end, & memory_start,memory_end ) Status = 1 if ( de1 - ds1 < 0 ) return if ( de2 - ds2 < 0 ) return if ( de3 - ds3 < 0 ) return if ( pe1 - ps1 < 0 ) return if ( pe2 - ps2 < 0 ) return if ( pe3 - ps3 < 0 ) return if ( me1 - ms1 < 0 ) return if ( me2 - ms2 < 0 ) return if ( me3 - ms3 < 0 ) return Status = 0 CALL wrf_read_field ( & DataHandle & ! DataHandle ,DateStr & ! DateStr ,Var & ! Data Name ,Field & ! Field ,FieldType & ! FieldType ,Comm & ! Comm ,IOComm & ! IOComm ,DomainDesc & ! DomainDesc ,bdy_mask & ! bdy_mask ,MemoryOrder & ! MemoryOrder ,Stagger & ! Stagger ,dimnames & ! JMMOD 1109 ,domain_start & ! DomainStart ,domain_end & ! DomainEnd ,memory_start & ! MemoryStart ,memory_end & ! MemoryEnd ,patch_start & ! PatchStart ,patch_end & ! PatchEnd ,Status ) IF ( wrf_at_debug_level(300) ) THEN WRITE(wrf_err_message,*) debug_message,' Status = ',Status CALL wrf_message ( TRIM(wrf_err_message) ) ENDIF END SUBROUTINE wrf_ext_read_field