share/wrf_tsin.F

   1 SUBROUTINE wrf_tsin ( grid , ierr )
   2
   3     USE module_domain
   4     USE module_utility
   5     USE module_configure, ONLY : model_config_rec, grid_config_rec_type, model_to_grid_config_rec
   6     USE module_string_tools, ONLY : capitalize
   7
   8     IMPLICIT NONE
   9
  10 #include "wrf_io_flags.h"
  11 #include "wrf_status_codes.h"
  12
  13     TYPE(domain), INTENT(INOUT) :: grid
  14     TYPE (grid_config_rec_type) :: config_flags
  15     INTEGER, INTENT(INOUT) :: ierr
  16
  17     LOGICAL, EXTERNAL :: wrf_dm_on_monitor
  18     INTEGER, EXTERNAL :: get_unused_unit
  19
  20     INTEGER :: istatus, iunit
  21     LOGICAL :: exists
  22     CHARACTER (LEN=256) :: errmess
  23     CHARACTER (LEN=256) :: IorLat,JorLon
  24
  25     ierr = 0
  26
  27     !
  28     ! If time series locations have already been computed by calc_ts_locations,
  29     ! assume that we have already read the 'tslist' file for this domain and return
  30     !
  31     IF ( grid%have_calculated_tslocs ) RETURN
  32
  33 #if ((EM_CORE == 1) && (DA_CORE != 1))
  34     IF ( grid%dfi_opt == DFI_NODFI .OR. (grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage == DFI_SETUP) ) THEN
  35 #endif
  36     CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
  37        grid%ntsloc = 0
  38
  39        IF ( grid%max_ts_locs <= 0 ) RETURN
  40
  41        IF ( wrf_dm_on_monitor() ) THEN
  42
  43           CALL wrf_tsin_exist ( exists )
  44
  45           IF (exists) THEN
  46
  47              iunit = get_unused_unit()
  48              IF ( iunit <= 0 ) THEN
  49                 CALL wrf_error_fatal('Error in wrf_tsin: could not find a free Fortran unit.')
  50              END IF
  51
  52              ! Input time series locations
  53              OPEN(UNIT=iunit, FILE='tslist', FORM='formatted', STATUS='old', IOSTAT=istatus)
  54              IF (istatus == 0) THEN
  55
  56                 ! The header will be parsed to see if lat/lon or i/j is given...
  57                 READ(UNIT=iunit, FMT='(1X)')
  58                 READ(UNIT=iunit, FMT='(32X,A7,2X,A7)') IorLat, JorLon
  59                 READ(UNIT=iunit, FMT='(1X)')
  60                 grid%tslist_ij = .false.
  61                 ! If the header contains "LAT" and "LON",
  62                 !    then it will expect lat/lon coords in the file
  63                 ! If the header has "I" and "J",
  64                 !    then it will expect grid index coords in the file
  65                 IorLat = capitalize(IorLat)
  66                 JorLon = capitalize(JorLon)
  67                 if(index(IorLat,'LAT').ne.0 .and. index(JorLon,'LON').ne.0) then
  68                     grid%tslist_ij = .false.
  69                 elseif(index(IorLat,'I').ne.0 .and. index(JorLon,'J').ne.0) then
  70                     grid%tslist_ij = .true.
  71                 else
  72                     CALL wrf_error_fatal('Error in wrf_tsin: Header line requires either LAT LON or I J')
  73                 endif
  74
  75
  76
  77
  78                 ! Read in time series locations
  79                 istatus = 0
  80                 DO WHILE (istatus == 0)
  81                    IF (config_flags%map_proj == 0 .OR. grid%tslist_ij) THEN !ideal run will only use i,j
  82                        READ(UNIT=iunit, FMT='(A25,1X,A5,1X,I7,1X,I8)', IOSTAT=istatus)            &
  83                        grid%desctsloc(grid%ntsloc+1), grid%nametsloc(grid%ntsloc+1), &
  84                        grid%itsloc(grid%ntsloc+1), grid%jtsloc(grid%ntsloc+1)
  85                    ELSE
  86                        READ(UNIT=iunit, FMT='(A25,1X,A5,1X,F7.3,1X,F8.3)', IOSTAT=istatus)            &
  87                        grid%desctsloc(grid%ntsloc+1), grid%nametsloc(grid%ntsloc+1), &
  88                        grid%lattsloc(grid%ntsloc+1), grid%lontsloc(grid%ntsloc+1)
  89                    END IF
  90                    IF (istatus == 0) grid%ntsloc = grid%ntsloc + 1
  91                    IF (istatus > 0) THEN
  92                       WRITE(errmess, FMT='(I4)') grid%ntsloc + 4   ! Three extra for the header of the file
  93                                                                    ! One extra for the line we incorrectly read
  94                       CALL wrf_message('Error in tslist, line '//trim(errmess))
  95                       CALL wrf_error_fatal('Error --- Maybe check that the header (I,J) vs (LAT,LON) matches the provided information')
  96                       EXIT    ! (technically unecessary, as we will exit the loop anyway)
  97                    END IF
  98                    IF ( ( grid%ntsloc == 1 ) .and. ( .NOT. grid%tslist_ij ) ) THEN
  99                       IF ( ( ABS(grid%lattsloc(grid%ntsloc)) <= 0.1 ) .and. &
 100                            ( ABS(grid%lontsloc(grid%ntsloc)) <= 0.1 ) ) THEN
 101                          CALL wrf_message('WARNING ')
 102                          CALL wrf_message('WARNING --- Maybe you have (I,J) locations for the (LAT,LON) values in tslist?')
 103                          CALL wrf_message('WARNING --- Are you purposefully studying Null Island?')
 104                          CALL wrf_message('WARNING ')
 105                       END IF
 106                    END IF
 107                    IF ( grid%ntsloc >= grid%max_ts_locs ) THEN
 108                       IF ( istatus == 0 ) THEN                 ! Assume there were more lines in the file
 109                          WRITE(errmess, FMT='(A,I4,A)') 'Ignoring all time series locations beyond #', &
 110                                                     grid%ntsloc,'. Increase max_ts_locs in namelist.input'
 111                          CALL wrf_message(trim(errmess))
 112                       END IF
 113                       EXIT
 114                    END IF
 115                 END DO
 116
 117                 CLOSE(iunit)
 118
 119              END IF
 120
 121           END IF  ! tslist file exists
 122
 123        END IF
 124
 125 #ifdef DM_PARALLEL
 126        CALL wrf_dm_bcast_integer(grid%ntsloc, 1)
 127        CALL wrf_dm_bcast_integer(grid%tslist_ij, 1)
 128        CALL wrf_dm_bcast_real(grid%lattsloc, grid%max_ts_locs)
 129        CALL wrf_dm_bcast_real(grid%lontsloc, grid%max_ts_locs)
 130        CALL wrf_dm_bcast_integer(grid%itsloc, grid%max_ts_locs)
 131        CALL wrf_dm_bcast_integer(grid%jtsloc, grid%max_ts_locs)
 132 #endif
 133 #if ((EM_CORE == 1) && (DA_CORE != 1))
 134     END IF
 135 #endif
 136
 137 END SUBROUTINE wrf_tsin
 138
 139 SUBROUTINE wrf_tsin_exist ( exists )
 140    IMPLICIT NONE
 141    LOGICAL , INTENT(OUT) :: exists
 142    INQUIRE(FILE='tslist', EXIST=exists)
 143 END SUBROUTINE wrf_tsin_exist
 144
 145
 146 INTEGER FUNCTION get_unused_unit()
 147
 148     IMPLICIT NONE
 149
 150     INTEGER, PARAMETER :: min_unit_number = 30
 151     INTEGER, PARAMETER :: max_unit_number = 99
 152
 153     LOGICAL :: opened
 154
 155     DO get_unused_unit = min_unit_number, max_unit_number
 156        INQUIRE(UNIT=get_unused_unit, OPENED=opened)
 157        IF ( .NOT. opened ) RETURN
 158     END DO
 159
 160     get_unused_unit = -1
 161
 162     RETURN
 163
 164 END FUNCTION get_unused_unit