wrfv2_fire/share/wrf_tsin.F

   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