| 1 | SUBROUTINE wrf_tsin ( grid , ierr ) |
|---|
| 2 | |
|---|
| 3 | USE module_domain |
|---|
| 4 | USE module_utility |
|---|
| 5 | |
|---|
| 6 | IMPLICIT NONE |
|---|
| 7 | |
|---|
| 8 | #include <wrf_io_flags.h> |
|---|
| 9 | #include <wrf_status_codes.h> |
|---|
| 10 | |
|---|
| 11 | TYPE(domain), INTENT(INOUT) :: grid |
|---|
| 12 | INTEGER, INTENT(INOUT) :: ierr |
|---|
| 13 | |
|---|
| 14 | LOGICAL, EXTERNAL :: wrf_dm_on_monitor |
|---|
| 15 | INTEGER, EXTERNAL :: get_unused_unit |
|---|
| 16 | |
|---|
| 17 | REAL, ALLOCATABLE, DIMENSION(:) :: lattslocs, lontslocs |
|---|
| 18 | INTEGER :: istatus, iunit |
|---|
| 19 | LOGICAL :: exists |
|---|
| 20 | CHARACTER (LEN=256) :: errmess |
|---|
| 21 | |
|---|
| 22 | ierr = 0 |
|---|
| 23 | |
|---|
| 24 | #if ((EM_CORE == 1) && (DA_CORE != 1)) |
|---|
| 25 | IF ( grid%dfi_opt == DFI_NODFI .OR. (grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage == DFI_SETUP) ) THEN |
|---|
| 26 | #endif |
|---|
| 27 | |
|---|
| 28 | grid%ntsloc = 0 |
|---|
| 29 | grid%have_calculated_tslocs = .FALSE. |
|---|
| 30 | |
|---|
| 31 | IF ( grid%max_ts_locs <= 0 ) RETURN |
|---|
| 32 | |
|---|
| 33 | IF ( wrf_dm_on_monitor() ) THEN |
|---|
| 34 | |
|---|
| 35 | INQUIRE(FILE='tslist', EXIST=exists) |
|---|
| 36 | |
|---|
| 37 | IF (exists) THEN |
|---|
| 38 | |
|---|
| 39 | iunit = get_unused_unit() |
|---|
| 40 | IF ( iunit <= 0 ) THEN |
|---|
| 41 | CALL wrf_error_fatal('Error in wrf_tsin: could not find a free Fortran unit.') |
|---|
| 42 | END IF |
|---|
| 43 | |
|---|
| 44 | ! Input time series locations |
|---|
| 45 | OPEN(UNIT=iunit, FILE='tslist', FORM='formatted', STATUS='old', IOSTAT=istatus) |
|---|
| 46 | |
|---|
| 47 | IF (istatus == 0) THEN |
|---|
| 48 | |
|---|
| 49 | ! Ignore first three lines, which constitute a header |
|---|
| 50 | READ(UNIT=iunit, FMT='(1X)') |
|---|
| 51 | READ(UNIT=iunit, FMT='(1X)') |
|---|
| 52 | READ(UNIT=iunit, FMT='(1X)') |
|---|
| 53 | |
|---|
| 54 | ! Read in time series locations |
|---|
| 55 | istatus = 0 |
|---|
| 56 | DO WHILE (istatus == 0) |
|---|
| 57 | READ(UNIT=iunit, FMT='(A25,1X,A5,1X,F7.3,1X,F8.3)', IOSTAT=istatus) & |
|---|
| 58 | grid%desctsloc(grid%ntsloc+1), grid%nametsloc(grid%ntsloc+1), & |
|---|
| 59 | grid%lattsloc(grid%ntsloc+1), grid%lontsloc(grid%ntsloc+1) |
|---|
| 60 | IF (istatus == 0) grid%ntsloc = grid%ntsloc + 1 |
|---|
| 61 | IF (istatus > 0) THEN |
|---|
| 62 | WRITE(errmess, FMT='(I4)') grid%ntsloc + 3 ! Three extra for the header of the file |
|---|
| 63 | CALL wrf_message('Error in tslist, line '//trim(errmess)) |
|---|
| 64 | EXIT ! (technically unecessary, as we will exit the loop anyway) |
|---|
| 65 | END IF |
|---|
| 66 | IF ( grid%ntsloc >= grid%max_ts_locs ) THEN |
|---|
| 67 | IF ( istatus == 0 ) THEN ! Assume there were more lines in the file |
|---|
| 68 | WRITE(errmess, FMT='(A,I4,A)') 'Ignoring all time series locations beyond #', & |
|---|
| 69 | grid%ntsloc,'. Increase max_ts_locs in namelist.input' |
|---|
| 70 | CALL wrf_message(trim(errmess)) |
|---|
| 71 | END IF |
|---|
| 72 | EXIT |
|---|
| 73 | END IF |
|---|
| 74 | END DO |
|---|
| 75 | |
|---|
| 76 | CLOSE(iunit) |
|---|
| 77 | |
|---|
| 78 | END IF |
|---|
| 79 | |
|---|
| 80 | END IF ! tslist file exists |
|---|
| 81 | |
|---|
| 82 | END IF |
|---|
| 83 | |
|---|
| 84 | #ifdef DM_PARALLEL |
|---|
| 85 | CALL wrf_dm_bcast_integer(grid%ntsloc, 1) |
|---|
| 86 | CALL wrf_dm_bcast_real(grid%lattsloc, grid%max_ts_locs) |
|---|
| 87 | CALL wrf_dm_bcast_real(grid%lontsloc, grid%max_ts_locs) |
|---|
| 88 | #endif |
|---|
| 89 | #if ((EM_CORE == 1) && (DA_CORE != 1)) |
|---|
| 90 | END IF |
|---|
| 91 | #endif |
|---|
| 92 | |
|---|
| 93 | END SUBROUTINE wrf_tsin |
|---|
| 94 | |
|---|
| 95 | |
|---|
| 96 | INTEGER FUNCTION get_unused_unit() |
|---|
| 97 | |
|---|
| 98 | IMPLICIT NONE |
|---|
| 99 | |
|---|
| 100 | INTEGER, PARAMETER :: min_unit_number = 30 |
|---|
| 101 | INTEGER, PARAMETER :: max_unit_number = 99 |
|---|
| 102 | |
|---|
| 103 | LOGICAL :: opened |
|---|
| 104 | |
|---|
| 105 | DO get_unused_unit = min_unit_number, max_unit_number |
|---|
| 106 | INQUIRE(UNIT=get_unused_unit, OPENED=opened) |
|---|
| 107 | IF ( .NOT. opened ) RETURN |
|---|
| 108 | END DO |
|---|
| 109 | |
|---|
| 110 | get_unused_unit = -1 |
|---|
| 111 | |
|---|
| 112 | RETURN |
|---|
| 113 | |
|---|
| 114 | END FUNCTION get_unused_unit |
|---|
