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