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