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