SUBROUTINE wrf_tsin ( grid , ierr ) 2,23
USE module_domain
USE module_utility
USE module_configure
, ONLY : model_config_rec, grid_config_rec_type, model_to_grid_config_rec
USE module_string_tools
, ONLY : capitalize
IMPLICIT NONE
#include "wrf_io_flags.h"
#include "wrf_status_codes.h"
TYPE(domain), INTENT(INOUT) :: grid
TYPE (grid_config_rec_type) :: config_flags
INTEGER, INTENT(INOUT) :: ierr
LOGICAL, EXTERNAL :: wrf_dm_on_monitor
INTEGER, EXTERNAL :: get_unused_unit
INTEGER :: istatus, iunit
LOGICAL :: exists
CHARACTER (LEN=256) :: errmess
CHARACTER (LEN=256) :: IorLat,JorLon
ierr = 0
#if ((EM_CORE == 1) && (DA_CORE != 1))
IF ( grid%dfi_opt == DFI_NODFI .OR. (grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage == DFI_SETUP) ) THEN
#endif
CALL model_to_grid_config_rec
( grid%id , model_config_rec , config_flags )
grid%ntsloc = 0
grid%have_calculated_tslocs = .FALSE.
IF ( grid%max_ts_locs <= 0 ) RETURN
IF ( wrf_dm_on_monitor() ) THEN
CALL wrf_tsin_exist
( exists )
IF (exists) THEN
iunit = get_unused_unit
()
IF ( iunit <= 0 ) THEN
CALL wrf_error_fatal
('Error in wrf_tsin: could not find a free Fortran unit.')
END IF
! Input time series locations
OPEN(UNIT=iunit, FILE='tslist', FORM='formatted', STATUS='old', IOSTAT=istatus)
IF (istatus == 0) THEN
! The header will be parsed to see if lat/lon or i/j is given...
READ(UNIT=iunit, FMT='(1X)')
READ(UNIT=iunit, FMT='(32X,A7,2X,A7)') IorLat, JorLon
READ(UNIT=iunit, FMT='(1X)')
grid%tslist_ij = .false.
! If the header contains "LAT" and "LON",
! then it will expect lat/lon coords in the file
! If the header has "I" and "J",
! then it will expect grid index coords in the file
IorLat = capitalize
(IorLat)
JorLon = capitalize
(JorLon)
if(index(IorLat,'LAT').ne.0 .and. index(JorLon,'LON').ne.0) then
grid%tslist_ij = .false.
elseif(index(IorLat,'I').ne.0 .and. index(JorLon,'J').ne.0) then
grid%tslist_ij = .true.
else
CALL wrf_error_fatal
('Error in wrf_tsin: Header line requires either LAT LON or I J')
endif
! Read in time series locations
istatus = 0
DO WHILE (istatus == 0)
IF (config_flags%map_proj == 0 .OR. grid%tslist_ij) THEN !ideal run will only use i,j
READ(UNIT=iunit, FMT='(A25,1X,A5,1X,I7,1X,I8)', IOSTAT=istatus) &
grid%desctsloc(grid%ntsloc+1), grid%nametsloc(grid%ntsloc+1), &
grid%itsloc(grid%ntsloc+1), grid%jtsloc(grid%ntsloc+1)
ELSE
READ(UNIT=iunit, FMT='(A25,1X,A5,1X,F7.3,1X,F8.3)', IOSTAT=istatus) &
grid%desctsloc(grid%ntsloc+1), grid%nametsloc(grid%ntsloc+1), &
grid%lattsloc(grid%ntsloc+1), grid%lontsloc(grid%ntsloc+1)
END IF
IF (istatus == 0) grid%ntsloc = grid%ntsloc + 1
IF (istatus > 0) THEN
WRITE(errmess, FMT='(I4)') grid%ntsloc + 4 ! Three extra for the header of the file
! One extra for the line we incorrectly read
CALL wrf_message
('Error in tslist, line '//trim(errmess))
CALL wrf_error_fatal
('Error --- Maybe check that the header (I,J) vs (LAT,LON) matches the provided information')
EXIT ! (technically unecessary, as we will exit the loop anyway)
END IF
IF ( ( grid%ntsloc == 1 ) .and. ( .NOT. grid%tslist_ij ) ) THEN
IF ( ( ABS(grid%lattsloc(grid%ntsloc)) <= 0.1 ) .and. &
( ABS(grid%lontsloc(grid%ntsloc)) <= 0.1 ) ) THEN
CALL wrf_message
('WARNING ')
CALL wrf_message
('WARNING --- Maybe you have (I,J) locations for the (LAT,LON) values in tslist?')
CALL wrf_message
('WARNING --- Are you purposefully studying Null Island?')
CALL wrf_message
('WARNING ')
END IF
END IF
IF ( grid%ntsloc >= grid%max_ts_locs ) THEN
IF ( istatus == 0 ) THEN ! Assume there were more lines in the file
WRITE(errmess, FMT='(A,I4,A)') 'Ignoring all time series locations beyond #', &
grid%ntsloc,'. Increase max_ts_locs in namelist.input'
CALL wrf_message
(trim(errmess))
END IF
EXIT
END IF
END DO
CLOSE(iunit)
END IF
END IF ! tslist file exists
END IF
#ifdef DM_PARALLEL
CALL wrf_dm_bcast_integer
(grid%ntsloc, 1)
CALL wrf_dm_bcast_integer
(grid%tslist_ij, 1)
CALL wrf_dm_bcast_real
(grid%lattsloc, grid%max_ts_locs)
CALL wrf_dm_bcast_real
(grid%lontsloc, grid%max_ts_locs)
CALL wrf_dm_bcast_integer
(grid%itsloc, grid%max_ts_locs)
CALL wrf_dm_bcast_integer
(grid%jtsloc, grid%max_ts_locs)
#endif
#if ((EM_CORE == 1) && (DA_CORE != 1))
END IF
#endif
END SUBROUTINE wrf_tsin
SUBROUTINE wrf_tsin_exist ( exists ) 2
IMPLICIT NONE
LOGICAL , INTENT(OUT) :: exists
INQUIRE(FILE='tslist', EXIST=exists)
END SUBROUTINE wrf_tsin_exist
INTEGER FUNCTION get_unused_unit() 19
IMPLICIT NONE
INTEGER, PARAMETER :: min_unit_number = 30
INTEGER, PARAMETER :: max_unit_number = 99
LOGICAL :: opened
DO get_unused_unit = min_unit_number, max_unit_number
INQUIRE(UNIT=get_unused_unit, OPENED=opened)
IF ( .NOT. opened ) RETURN
END DO
get_unused_unit = -1
RETURN
END FUNCTION get_unused_unit