wrfv2_fire/share/module_io_domain.F

   1 !WRF:MEDIATION_LAYER:IO
   2 !
   3
   4 MODULE module_io_domain
   5 USE module_io
   6 USE module_io_wrf
   7 USE module_configure, ONLY : grid_config_rec_type
   8 USE module_domain, ONLY : domain
   9
  10 CONTAINS
  11
  12   SUBROUTINE open_r_dataset ( id , fname , grid , config_flags , sysdepinfo, ierr )
  13    TYPE (domain)             :: grid
  14    CHARACTER*(*) :: fname
  15    CHARACTER*(*) :: sysdepinfo
  16    INTEGER      , INTENT(INOUT) :: id , ierr
  17    LOGICAL , EXTERNAL :: wrf_dm_on_monitor
  18    TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
  19    CHARACTER*128             :: DataSet
  20    LOGICAL                   :: anyway
  21    CALL wrf_open_for_read ( fname ,                     &
  22                             grid%communicator ,         &
  23                             grid%iocommunicator ,       &
  24                             sysdepinfo ,                &
  25                             id ,                        &
  26                             ierr )
  27    RETURN
  28   END SUBROUTINE open_r_dataset
  29
  30   SUBROUTINE open_w_dataset ( id , fname , grid , config_flags , outsub , sysdepinfo, ierr )
  31    TYPE (domain)             :: grid
  32    CHARACTER*(*) :: fname
  33    CHARACTER*(*) :: sysdepinfo
  34    INTEGER      , INTENT(INOUT) :: id , ierr
  35    TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
  36    LOGICAL , EXTERNAL :: wrf_dm_on_monitor
  37    EXTERNAL outsub
  38    CHARACTER*128             :: DataSet
  39    LOGICAL                   :: anyway
  40    CALL wrf_debug ( 100 , 'calling wrf_open_for_write_begin in open_w_dataset' )
  41    CALL wrf_open_for_write_begin ( fname ,     &
  42                                    grid%communicator ,         &
  43                                    grid%iocommunicator ,       &
  44                                    sysdepinfo ,                &
  45                                    id ,                        &
  46                                    ierr )
  47    IF ( ierr .LE. 0 ) THEN
  48      CALL wrf_debug ( 100 , 'calling outsub in open_w_dataset' )
  49      CALL outsub( id , grid , config_flags , ierr )
  50      CALL wrf_debug ( 100 , 'back from outsub in open_w_dataset' )
  51    ENDIF
  52    IF ( ierr .LE. 0 ) THEN
  53      CALL wrf_debug ( 100 , 'calling wrf_open_for_write_commit in open_w_dataset' )
  54      CALL wrf_open_for_write_commit ( id ,                        &
  55                                       ierr )
  56      CALL wrf_debug ( 100 , 'back from wrf_open_for_write_commit in open_w_dataset' )
  57    ENDIF
  58   END SUBROUTINE open_w_dataset
  59
  60   SUBROUTINE open_u_dataset ( id , fname , grid , config_flags , insub , sysdepinfo, ierr )
  61    TYPE (domain)             :: grid
  62    CHARACTER*(*) :: fname
  63    CHARACTER*(*) :: sysdepinfo
  64    INTEGER      , INTENT(INOUT) :: id , ierr
  65    TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
  66    LOGICAL , EXTERNAL :: wrf_dm_on_monitor
  67    EXTERNAL insub
  68    CHARACTER*128             :: DataSet
  69    LOGICAL                   :: anyway
  70    CALL wrf_debug ( 100 , 'calling wrf_open_for_read_begin in open_u_dataset' )
  71    CALL wrf_open_for_read_begin ( fname ,     &
  72                                    grid%communicator ,         &
  73                                    grid%iocommunicator ,       &
  74                                    sysdepinfo ,                &
  75                                    id ,                        &
  76                                    ierr )
  77    IF ( ierr .LE. 0 ) THEN
  78      CALL wrf_debug ( 100 , 'calling insub in open_u_dataset' )
  79      CALL insub( id , grid , config_flags , ierr )
  80    ENDIF
  81    IF ( ierr .LE. 0 ) THEN
  82      CALL wrf_debug ( 100 , 'calling wrf_open_for_read_commit in open_u_dataset' )
  83      CALL wrf_open_for_read_commit ( id ,                        &
  84                                        ierr )
  85      CALL wrf_debug ( 100 , 'back from wrf_open_for_read_commit in open_u_dataset' )
  86    ENDIF
  87   END SUBROUTINE open_u_dataset
  88
  89   SUBROUTINE close_dataset( id , config_flags, sysdepinfo )
  90    IMPLICIT NONE
  91    INTEGER id , ierr
  92    LOGICAL , EXTERNAL :: wrf_dm_on_monitor
  93    TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
  94    CHARACTER*(*) :: sysdepinfo
  95    CHARACTER*128             :: DataSet
  96    LOGICAL                   :: anyway
  97    CALL wrf_ioclose( id , ierr )
  98   END SUBROUTINE close_dataset
  99
 100
 101 ! ------------  Output model input data sets
 102
 103 #include "module_io_domain_defs.inc"
 104
 105 !  ------------ Input model restart data sets
 106
 107   SUBROUTINE input_restart ( fid , grid , config_flags , ierr )
 108     IMPLICIT NONE
 109     TYPE(domain) :: grid
 110     TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
 111     INTEGER, INTENT(IN) :: fid
 112     INTEGER, INTENT(INOUT) :: ierr
 113     IF ( config_flags%io_form_restart .GT. 0 ) THEN
 114       CALL input_wrf ( fid , grid , config_flags , restart_only , ierr )
 115     ENDIF
 116     RETURN
 117   END SUBROUTINE input_restart
 118
 119 !  ------------ Input model boundary data sets
 120
 121   SUBROUTINE input_boundary ( fid , grid , config_flags , ierr )
 122     IMPLICIT NONE
 123     TYPE(domain) :: grid
 124     TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
 125     INTEGER, INTENT(IN) :: fid
 126     INTEGER, INTENT(INOUT) :: ierr
 127     IF ( config_flags%io_form_boundary .GT. 0 ) THEN
 128       CALL input_wrf ( fid , grid , config_flags , boundary_only , ierr )
 129     ENDIF
 130     RETURN
 131   END SUBROUTINE input_boundary
 132
 133 !  ------------ Output model restart data sets
 134
 135   SUBROUTINE output_restart ( fid , grid , config_flags , ierr )
 136     IMPLICIT NONE
 137     TYPE(domain) :: grid
 138     TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
 139     INTEGER, INTENT(IN) :: fid
 140     INTEGER, INTENT(INOUT) :: ierr
 141     IF ( config_flags%io_form_restart .GT. 0 ) THEN
 142 #ifdef HWRF
 143 !zhang: HWRF for bit reproducibility of random numbers when restarting
 144              call random_seed(get=grid%nrnd1)
 145 #endif
 146       CALL output_wrf ( fid , grid , config_flags , restart_only , ierr )
 147     ENDIF
 148     RETURN
 149   END SUBROUTINE output_restart
 150
 151 !  ------------ Output model boundary data sets
 152
 153   SUBROUTINE output_boundary ( fid , grid , config_flags , ierr )
 154     IMPLICIT NONE
 155     TYPE(domain) :: grid
 156     TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
 157     INTEGER, INTENT(IN) :: fid
 158     INTEGER, INTENT(INOUT) :: ierr
 159     IF ( config_flags%io_form_boundary .GT. 0 ) THEN
 160       CALL output_wrf ( fid , grid , config_flags , boundary_only , ierr )
 161     ENDIF
 162     RETURN
 163   END SUBROUTINE output_boundary
 164
 165 END MODULE module_io_domain
 166
 167 ! move outside module so callable without USE of module
 168 SUBROUTINE construct_filename1( result , basename , fld1 , len1 )
 169   IMPLICIT NONE
 170   CHARACTER*(*) :: result
 171   CHARACTER*(*) :: basename
 172   INTEGER , INTENT(IN) :: fld1 , len1
 173   CHARACTER*64         :: t1, zeros
 174
 175   CALL zero_pad ( t1 , fld1 , len1 )
 176   result = TRIM(basename) // "_d" // TRIM(t1)
 177   CALL maybe_remove_colons(result)
 178   RETURN
 179 END SUBROUTINE construct_filename1
 180
 181 SUBROUTINE construct_filename2( result , basename , fld1 , len1 , date_char )
 182   IMPLICIT NONE
 183   CHARACTER*(*) :: result
 184   CHARACTER*(*) :: basename
 185   CHARACTER*(*) :: date_char
 186
 187   INTEGER , INTENT(IN) :: fld1 , len1
 188   CHARACTER*64         :: t1, zeros
 189   CALL zero_pad ( t1 , fld1 , len1 )
 190   result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char)
 191   CALL maybe_remove_colons(result)
 192   RETURN
 193 END SUBROUTINE construct_filename2
 194
 195 ! this version looks for <date> and <domain> in the basename and replaces with the arguments
 196
 197 SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char )
 198   IMPLICIT NONE
 199   CHARACTER*(*) :: result
 200   CHARACTER*(*) :: basename
 201   CHARACTER*(*) :: date_char
 202   INTEGER , INTENT(IN) :: fld1 , len1
 203   CHARACTER*64         :: t1, zeros
 204   INTEGER   i, j, l
 205
 206   result=basename
 207   CALL zero_pad ( t1 , fld1 , len1 )
 208   i = index( basename , '<domain>' )
 209   l = len(trim(basename))
 210   IF ( i .GT. 0 ) THEN
 211     result = basename(1:i-1) // TRIM(t1) // basename(i+8:l)
 212   ENDIF
 213   i = index( result , '<date>' )
 214   l = len(trim(result))
 215   IF ( i .GT. 0 ) THEN
 216     result = result(1:i-1) // TRIM(date_char) // result(i+6:l)
 217   ENDIF
 218   CALL maybe_remove_colons(result)
 219   RETURN
 220 END SUBROUTINE construct_filename2a
 221
 222 SUBROUTINE construct_filename ( result , basename , fld1 , len1 , fld2 , len2 )
 223   IMPLICIT NONE
 224   CHARACTER*(*) :: result
 225   CHARACTER*(*) :: basename
 226   INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2
 227   CHARACTER*64         :: t1, t2, zeros
 228
 229   CALL zero_pad ( t1 , fld1 , len1 )
 230   CALL zero_pad ( t2 , fld2 , len2 )
 231   result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2)
 232   CALL maybe_remove_colons(result)
 233   RETURN
 234 END SUBROUTINE construct_filename
 235
 236 SUBROUTINE construct_filename3 ( result , basename , fld1 , len1 , fld2 , len2, fld3, len3 )
 237   IMPLICIT NONE
 238   CHARACTER*(*) :: result
 239   CHARACTER*(*) :: basename
 240   INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2, fld3, len3
 241   CHARACTER*64         :: t1, t2, t3, zeros
 242
 243   CALL zero_pad ( t1 , fld1 , len1 )
 244   CALL zero_pad ( t2 , fld2 , len2 )
 245   CALL zero_pad ( t3 , fld3 , len3 )
 246   result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) // "_" // TRIM(t3)
 247   CALL maybe_remove_colons(result)
 248   RETURN
 249 END SUBROUTINE construct_filename3
 250
 251 SUBROUTINE construct_filename4( result , basename , fld1 , len1 , date_char , io_form )
 252   USE module_state_description
 253   IMPLICIT NONE
 254   CHARACTER*(*) :: result
 255   CHARACTER*(*) :: basename
 256   CHARACTER*(*) :: date_char
 257
 258   INTEGER, EXTERNAL :: use_package
 259   INTEGER , INTENT(IN) :: fld1 , len1 , io_form
 260   CHARACTER*64         :: t1, zeros
 261   CHARACTER*4          :: ext
 262   CALL zero_pad ( t1 , fld1 , len1 )
 263   IF      ( use_package(io_form) .EQ. IO_INTIO ) THEN
 264      ext = '.int'
 265   ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN
 266      ext = '.nc '
 267   ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN
 268     ext = '.nc '
 269   ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN
 270      ext = '.gb '
 271   ELSE
 272      CALL wrf_error_fatal ('improper io_form')
 273   END IF
 274   result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) // TRIM(ext)
 275   CALL maybe_remove_colons(result)
 276   RETURN
 277 END SUBROUTINE construct_filename4
 278
 279 ! this version looks for <date> and <domain> in the basename and replaces with the arguments
 280
 281 SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , io_form )
 282   USE module_state_description
 283   IMPLICIT NONE
 284   CHARACTER*(*) :: result
 285   CHARACTER*(*) :: basename
 286   CHARACTER*(*) :: date_char
 287
 288   INTEGER, EXTERNAL :: use_package
 289   INTEGER , INTENT(IN) :: fld1 , len1 , io_form
 290   CHARACTER*64         :: t1, zeros
 291   CHARACTER*4          :: ext
 292   INTEGER   i, j, l
 293   result=basename
 294   CALL zero_pad ( t1 , fld1 , len1 )
 295   IF      ( use_package(io_form) .EQ. IO_INTIO ) THEN
 296      ext = '.int'
 297   ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN
 298      ext = '.nc '
 299   ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN
 300     ext = '.nc '
 301   ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN
 302      ext = '.gb '
 303   ELSE
 304      CALL wrf_error_fatal ('improper io_form')
 305   END IF
 306   l = len(trim(basename))
 307   result = basename(1:l) // TRIM(ext)
 308   i = index( result , '<domain>' )
 309   l = len(trim(result))
 310   IF ( i .GT. 0 ) THEN
 311     result = result(1:i-1) // TRIM(t1) // result(i+8:l)
 312   ENDIF
 313   i = index( result , '<date>' )
 314   l = len(trim(result))
 315   IF ( i .GT. 0 ) THEN
 316     result = result(1:i-1) // TRIM(date_char) // result(i+6:l)
 317   ENDIF
 318   CALL maybe_remove_colons(result)
 319   RETURN
 320 END SUBROUTINE construct_filename4a
 321
 322 SUBROUTINE append_to_filename ( result , basename , fld1 , len1 )
 323   IMPLICIT NONE
 324   CHARACTER*(*) :: result
 325   CHARACTER*(*) :: basename
 326   INTEGER , INTENT(IN) :: fld1 , len1
 327   CHARACTER*64         :: t1, zeros
 328
 329   CALL zero_pad ( t1 , fld1 , len1 )
 330   result = TRIM(basename) // "_" // TRIM(t1)
 331   CALL maybe_remove_colons(result)
 332   RETURN
 333 END SUBROUTINE append_to_filename
 334
 335 SUBROUTINE zero_pad ( result , fld1 , len1 )
 336   IMPLICIT NONE
 337   CHARACTER*(*) :: result
 338   INTEGER , INTENT (IN)      :: fld1 , len1
 339   INTEGER                    :: d , x
 340   CHARACTER*64         :: t2, zeros
 341   x = fld1 ; d = 0
 342   DO WHILE ( x > 0 )
 343     x = x / 10
 344     d = d + 1
 345   END DO
 346   write(t2,'(I9)')fld1
 347   zeros = '0000000000000000000000000000000'
 348   result = zeros(1:len1-d) // t2(9-d+1:9)
 349   RETURN
 350 END SUBROUTINE zero_pad
 351
 352 SUBROUTINE init_wrfio
 353    USE module_io, ONLY : wrf_ioinit
 354    IMPLICIT NONE
 355    INTEGER ierr
 356    CALL wrf_ioinit(ierr)
 357 END SUBROUTINE init_wrfio
 358
 359 !<DESCRIPTION>
 360 ! This routine figures out the nearest previous time instant
 361 ! that corresponds to a multiple of the input time interval.
 362 ! Example use is to give the time instant that corresponds to
 363 ! an I/O interval, even when the current time is a little bit
 364 ! past that time when, for example, the number of model time
 365 ! steps does not evenly divide the I/O interval. JM 20051013
 366 !</DESCRIPTION>
 367 !
 368 SUBROUTINE adjust_io_timestr ( TI, CT, ST, timestr )
 369    USE module_utility
 370    IMPLICIT NONE
 371 ! Args
 372    TYPE(WRFU_Time), INTENT(IN)            :: ST,CT    ! domain start and current time
 373    TYPE(WRFU_TimeInterval), INTENT(IN)    :: TI       ! interval
 374    CHARACTER*(*), INTENT(INOUT)           :: timestr  ! returned string
 375 ! Local
 376    TYPE(WRFU_Time)                        :: OT
 377    TYPE(WRFU_TimeInterval)                :: IOI
 378    INTEGER                                :: n
 379
 380    IOI = CT-ST                               ! length of time since starting
 381    n = WRFU_TimeIntervalDIVQuot( IOI , TI )  ! number of whole time intervals
 382    IOI = TI * n                              ! amount of time since starting in whole time intervals
 383    OT = ST + IOI                             ! previous nearest time instant
 384    CALL wrf_timetoa( OT, timestr )           ! generate string
 385    RETURN
 386 END SUBROUTINE adjust_io_timestr
 387
 388 ! Modify the filename to remove things like ':' from the file name
 389 ! unless it is a drive number. Convert to '_' instead.
 390
 391 SUBROUTINE maybe_remove_colons( FileName )
 392   CHARACTER*(*) FileName
 393   CHARACTER c, d
 394   INTEGER i, l
 395   LOGICAL nocolons
 396   l = LEN(TRIM(FileName))
 397 ! do not change first two characters (naive way of dealing with
 398 ! possiblity of drive name in a microsoft path
 399   CALL nl_get_nocolons(1,nocolons)
 400   IF ( nocolons ) THEN
 401     DO i = 3, l
 402       IF ( FileName(i:i) .EQ. ':' ) THEN
 403         FileName(i:i) = '_'
 404       ENDIF
 405     ENDDO
 406   ENDIF
 407   RETURN
 408 END
 409
 410
 411