share/track_input.F

   1 SUBROUTINE track_input ( 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 #if ( EM_CORE == 1 )
  15
  16     LOGICAL, EXTERNAL :: wrf_dm_on_monitor
  17     INTEGER, EXTERNAL :: get_unused_unit
  18
  19     INTEGER :: istatus, iunit, istatus2
  20     LOGICAL :: exists
  21     CHARACTER (LEN=256) :: errmess
  22
  23     ierr = 0
  24
  25 #ifndef NETCDF
  26     call wrf_message( 'calc_track_locations: requires netcdf' )
  27     call wrf_abort
  28 #endif
  29 #if ( DA_CORE != 1 )
  30     IF ( grid%dfi_opt == DFI_NODFI .OR. (grid%dfi_opt /= DFI_NODFI .AND. grid%dfi_stage == DFI_SETUP) ) THEN
  31 #endif
  32
  33        IF ( grid%track_have_input .or. grid%track_loc_in <= 0 ) then
  34          RETURN
  35        ENDIF
  36
  37        grid%track_loc = 0
  38 master_proc : &
  39        IF ( wrf_dm_on_monitor() ) THEN
  40          INQUIRE(FILE='wrfinput_track.txt', EXIST=exists)
  41 have_input_file : &
  42          IF (exists) THEN
  43            iunit = get_unused_unit()
  44            IF ( iunit <= 0 ) THEN
  45               CALL wrf_error_fatal('Error in track_input: could not find a free Fortran unit.')
  46            END IF
  47
  48 ! Input track locations
  49            OPEN(UNIT=iunit, FILE='wrfinput_track.txt', FORM='formatted', STATUS='old', IOSTAT=istatus)
  50            IF (istatus == 0) THEN
  51 ! Read in track locations
  52              istatus2 = 0
  53              DO WHILE (istatus2 == 0)
  54                READ(UNIT=iunit, FMT='(A19,1X,F7.3,1X,F8.3)', IOSTAT=istatus2)        &
  55                       grid%track_time_in(grid%track_loc+1),                          &
  56                       grid%track_lat_in(grid%track_loc+1),                           &
  57                       grid%track_lon_in(grid%track_loc+1)
  58
  59                if (istatus2 == 0 ) then
  60                  grid%track_loc = grid%track_loc + 1
  61                elseif (istatus2 > 0) then
  62                  WRITE(errmess, FMT='(I4)') grid%track_loc + 1   ! One extra for the header of the file
  63                  CALL wrf_message('Error in track_input.txt, line '//trim(errmess))
  64                  EXIT    ! (technically unecessary, as we will exit the loop anyway)
  65                endif
  66
  67                IF ( grid%track_loc >= grid%track_loc_in ) THEN
  68                  IF ( istatus2 == 0 ) THEN                 ! Assume there were more lines in the file
  69                    WRITE(errmess, FMT='(A,I4,A)') 'Ignoring all track locations beyond #', &
  70                                                   grid%track_loc,'. Increase track_loc_in in namelist.input'
  71                    CALL wrf_message(trim(errmess))
  72                  ENDIF
  73                  EXIT
  74                ENDIF
  75              END DO  ! istatus2 == 0
  76              CLOSE(iunit)
  77            ENDIF   ! istatus == 0
  78          ELSE have_input_file
  79            CALL wrf_error_fatal('Error in track_input: could not find wrfinput_track.txt file.')
  80          ENDIF have_input_file
  81
  82          write(errmess,*) 'track_input: total input locations = ',grid%track_loc
  83          call wrf_message( trim(errmess) )
  84 !         print *,'track_input: track_loc_in         = ',grid%track_loc_in
  85        ENDIF master_proc
  86
  87 #ifdef DM_PARALLEL
  88        CALL wrf_dm_bcast_integer(grid%track_loc, 1)
  89        CALL wrf_dm_bcast_real(grid%track_time_in, grid%track_loc)
  90        CALL wrf_dm_bcast_real(grid%track_lat_in, grid%track_loc)
  91        CALL wrf_dm_bcast_real(grid%track_lon_in, grid%track_loc)
  92 #endif
  93
  94     grid%track_have_input = .TRUE.
  95
  96 #if ( DA_CORE != 1 )
  97     END IF
  98 #endif
  99 #endif
 100
 101 END SUBROUTINE track_input