source: lmdz_wrf/trunk/WRFV3/share/module_io_domain.F @ 1285

Last change on this file since 1285 was 1, checked in by lfita, 11 years ago
  • -- --- Opening of the WRF+LMDZ coupling repository --- -- -

WRF: version v3.3
LMDZ: version v1818

More details in:

File size: 13.9 KB
Line 
1!WRF:MEDIATION_LAYER:IO
2!
3
4MODULE module_io_domain
5USE module_io
6USE module_io_wrf
7USE module_configure, ONLY : grid_config_rec_type
8USE module_domain, ONLY : domain
9
10CONTAINS
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#ifdef HWRF
149!zhang: HWRF for bit reproducibility of random numbers when restarting
150             call random_seed(get=grid%nrnd1)
151#endif
152      CALL output_wrf ( fid , grid , config_flags , restart_only , ierr )
153    ENDIF
154    RETURN
155  END SUBROUTINE output_restart
156
157!  ------------ Output model boundary data sets
158
159  SUBROUTINE output_boundary ( fid , grid , config_flags , ierr )
160    IMPLICIT NONE
161    TYPE(domain) :: grid
162    TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
163    INTEGER, INTENT(IN) :: fid
164    INTEGER, INTENT(INOUT) :: ierr
165    IF ( config_flags%io_form_boundary .GT. 0 ) THEN
166      CALL output_wrf ( fid , grid , config_flags , boundary_only , ierr )
167    ENDIF
168    RETURN
169  END SUBROUTINE output_boundary
170
171END MODULE module_io_domain
172
173! move outside module so callable without USE of module
174SUBROUTINE construct_filename1( result , basename , fld1 , len1 )
175  IMPLICIT NONE
176  CHARACTER*(*) :: result
177  CHARACTER*(*) :: basename
178  INTEGER , INTENT(IN) :: fld1 , len1
179  CHARACTER*64         :: t1, zeros
180 
181  CALL zero_pad ( t1 , fld1 , len1 )
182  result = TRIM(basename) // "_d" // TRIM(t1)
183  CALL maybe_remove_colons(result)
184  RETURN
185END SUBROUTINE construct_filename1
186
187SUBROUTINE construct_filename2( result , basename , fld1 , len1 , date_char )
188  IMPLICIT NONE
189  CHARACTER*(*) :: result
190  CHARACTER*(*) :: basename
191  CHARACTER*(*) :: date_char
192
193  INTEGER , INTENT(IN) :: fld1 , len1
194  CHARACTER*64         :: t1, zeros
195  CALL zero_pad ( t1 , fld1 , len1 )
196  result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char)
197  CALL maybe_remove_colons(result)
198  RETURN
199END SUBROUTINE construct_filename2
200
201! this version looks for <date> and <domain> in the basename and replaces with the arguments
202
203SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char )
204  IMPLICIT NONE
205  CHARACTER*(*) :: result
206  CHARACTER*(*) :: basename
207  CHARACTER*(*) :: date_char
208  INTEGER , INTENT(IN) :: fld1 , len1
209  CHARACTER*64         :: t1, zeros
210  INTEGER   i, j, l
211
212  result=basename
213  CALL zero_pad ( t1 , fld1 , len1 )
214  i = index( basename , '<domain>' )
215  l = len(trim(basename))
216  IF ( i .GT. 0 ) THEN
217    result = basename(1:i-1) // TRIM(t1) // basename(i+8:l)
218  ENDIF
219  i = index( result , '<date>' )
220  l = len(trim(result))
221  IF ( i .GT. 0 ) THEN
222    result = result(1:i-1) // TRIM(date_char) // result(i+6:l)
223  ENDIF
224  CALL maybe_remove_colons(result)
225  RETURN
226END SUBROUTINE construct_filename2a
227
228SUBROUTINE construct_filename ( result , basename , fld1 , len1 , fld2 , len2 )
229  IMPLICIT NONE
230  CHARACTER*(*) :: result
231  CHARACTER*(*) :: basename
232  INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2
233  CHARACTER*64         :: t1, t2, zeros
234 
235  CALL zero_pad ( t1 , fld1 , len1 )
236  CALL zero_pad ( t2 , fld2 , len2 )
237  result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2)
238  CALL maybe_remove_colons(result)
239  RETURN
240END SUBROUTINE construct_filename
241
242SUBROUTINE construct_filename3 ( result , basename , fld1 , len1 , fld2 , len2, fld3, len3 )
243  IMPLICIT NONE
244  CHARACTER*(*) :: result
245  CHARACTER*(*) :: basename
246  INTEGER , INTENT(IN) :: fld1 , len1 , fld2 , len2, fld3, len3
247  CHARACTER*64         :: t1, t2, t3, zeros
248
249  CALL zero_pad ( t1 , fld1 , len1 )
250  CALL zero_pad ( t2 , fld2 , len2 )
251  CALL zero_pad ( t3 , fld3 , len3 )
252  result = TRIM(basename) // "_d" // TRIM(t1) // "_" // TRIM(t2) // "_" // TRIM(t3)
253  CALL maybe_remove_colons(result)
254  RETURN
255END SUBROUTINE construct_filename3
256
257SUBROUTINE construct_filename4( result , basename , fld1 , len1 , date_char , io_form )
258  USE module_state_description
259  IMPLICIT NONE
260  CHARACTER*(*) :: result
261  CHARACTER*(*) :: basename
262  CHARACTER*(*) :: date_char
263
264  INTEGER, EXTERNAL :: use_package
265  INTEGER , INTENT(IN) :: fld1 , len1 , io_form
266  CHARACTER*64         :: t1, zeros
267  CHARACTER*4          :: ext
268  CALL zero_pad ( t1 , fld1 , len1 )
269  IF      ( use_package(io_form) .EQ. IO_INTIO ) THEN
270     ext = '.int'
271  ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN
272     ext = '.nc '
273  ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN
274    ext = '.nc '
275  ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN
276     ext = '.gb '
277  ELSE
278     CALL wrf_error_fatal ('improper io_form')
279  END IF
280  result = TRIM(basename) // ".d" // TRIM(t1) // "." // TRIM(date_char) // TRIM(ext)
281  CALL maybe_remove_colons(result)
282  RETURN
283END SUBROUTINE construct_filename4
284
285! this version looks for <date> and <domain> in the basename and replaces with the arguments
286
287SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , io_form )
288  USE module_state_description
289  IMPLICIT NONE
290  CHARACTER*(*) :: result
291  CHARACTER*(*) :: basename
292  CHARACTER*(*) :: date_char
293
294  INTEGER, EXTERNAL :: use_package
295  INTEGER , INTENT(IN) :: fld1 , len1 , io_form
296  CHARACTER*64         :: t1, zeros
297  CHARACTER*4          :: ext
298  INTEGER   i, j, l
299  result=basename
300  CALL zero_pad ( t1 , fld1 , len1 )
301  IF      ( use_package(io_form) .EQ. IO_INTIO ) THEN
302     ext = '.int'
303  ELSE IF ( use_package(io_form) .EQ. IO_NETCDF ) THEN
304     ext = '.nc '
305  ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN
306    ext = '.nc '
307  ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN
308     ext = '.gb '
309  ELSE
310     CALL wrf_error_fatal ('improper io_form')
311  END IF
312  l = len(trim(basename))
313  result = basename(1:l) // TRIM(ext)
314  i = index( result , '<domain>' )
315  l = len(trim(result))
316  IF ( i .GT. 0 ) THEN
317    result = result(1:i-1) // TRIM(t1) // result(i+8:l)
318  ENDIF
319  i = index( result , '<date>' )
320  l = len(trim(result))
321  IF ( i .GT. 0 ) THEN
322    result = result(1:i-1) // TRIM(date_char) // result(i+6:l)
323  ENDIF
324  CALL maybe_remove_colons(result)
325  RETURN
326END SUBROUTINE construct_filename4a
327
328SUBROUTINE append_to_filename ( result , basename , fld1 , len1 )
329  IMPLICIT NONE
330  CHARACTER*(*) :: result
331  CHARACTER*(*) :: basename
332  INTEGER , INTENT(IN) :: fld1 , len1
333  CHARACTER*64         :: t1, zeros
334 
335  CALL zero_pad ( t1 , fld1 , len1 )
336  result = TRIM(basename) // "_" // TRIM(t1)
337  CALL maybe_remove_colons(result)
338  RETURN
339END SUBROUTINE append_to_filename
340
341SUBROUTINE zero_pad ( result , fld1 , len1 )
342  IMPLICIT NONE
343  CHARACTER*(*) :: result
344  INTEGER , INTENT (IN)      :: fld1 , len1
345  INTEGER                    :: d , x
346  CHARACTER*64         :: t2, zeros
347  x = fld1 ; d = 0
348  DO WHILE ( x > 0 )
349    x = x / 10
350    d = d + 1
351  END DO
352  write(t2,'(I9)')fld1
353  zeros = '0000000000000000000000000000000'
354  result = zeros(1:len1-d) // t2(9-d+1:9)
355  RETURN
356END SUBROUTINE zero_pad
357
358SUBROUTINE init_wrfio
359   USE module_io, ONLY : wrf_ioinit
360   IMPLICIT NONE
361   INTEGER ierr
362   CALL wrf_ioinit(ierr)
363END SUBROUTINE init_wrfio
364
365!<DESCRIPTION>
366! This routine figures out the nearest previous time instant
367! that corresponds to a multiple of the input time interval.
368! Example use is to give the time instant that corresponds to
369! an I/O interval, even when the current time is a little bit
370! past that time when, for example, the number of model time
371! steps does not evenly divide the I/O interval. JM 20051013
372!</DESCRIPTION>
373!
374SUBROUTINE adjust_io_timestr ( TI, CT, ST, timestr )
375   USE module_utility
376   IMPLICIT NONE
377! Args
378   TYPE(WRFU_Time), INTENT(IN)            :: ST,CT    ! domain start and current time
379   TYPE(WRFU_TimeInterval), INTENT(IN)    :: TI       ! interval
380   CHARACTER*(*), INTENT(INOUT)           :: timestr  ! returned string
381! Local
382   TYPE(WRFU_Time)                        :: OT
383   TYPE(WRFU_TimeInterval)                :: IOI
384   INTEGER                                :: n
385
386   IOI = CT-ST                               ! length of time since starting
387   n = WRFU_TimeIntervalDIVQuot( IOI , TI )  ! number of whole time intervals
388   IOI = TI * n                              ! amount of time since starting in whole time intervals
389   OT = ST + IOI                             ! previous nearest time instant
390   CALL wrf_timetoa( OT, timestr )           ! generate string
391   RETURN
392END SUBROUTINE adjust_io_timestr
393
394! Modify the filename to remove things like ':' from the file name
395! unless it is a drive number. Convert to '_' instead.
396
397SUBROUTINE maybe_remove_colons( FileName )
398  CHARACTER*(*) FileName
399  CHARACTER c, d
400  INTEGER i, l
401  LOGICAL nocolons
402  l = LEN(TRIM(FileName))
403! do not change first two characters (naive way of dealing with
404! possiblity of drive name in a microsoft path
405  CALL nl_get_nocolons(1,nocolons)
406  IF ( nocolons ) THEN
407    DO i = 3, l
408      IF ( FileName(i:i) .EQ. ':' ) THEN
409        FileName(i:i) = '_'
410      ENDIF
411    ENDDO
412  ENDIF
413  RETURN
414END
415
416
417
Note: See TracBrowser for help on using the repository browser.