forked from wrf-model/WRF
-
Notifications
You must be signed in to change notification settings - Fork 0
/
wrf_ext_write_field.F
307 lines (282 loc) · 14.7 KB
/
wrf_ext_write_field.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
!WRF:MEDIATION:IO
SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var &
,Field &
,idx4, idx5, idx6, idx7 &
,nx4 , nx5 , nx6 &
,TypeSizeInBytes &
,FieldType,grid &
,DomainDesc &
,bdy_mask &
,dryrun &
,MemoryOrder &
,Stagger &
,Dimname1, Dimname2, Dimname3 &
,Desc, Units &
,debug_message &
,ds1, de1, ds2, de2, ds3, de3 &
,ms1, me1, ms2, me2, ms3, me3 &
,ps1, pe1, ps2, pe2, ps3, pe3, Status )
USE module_io
USE module_wrf_error
USE module_state_description
USE module_timing
USE module_domain
IMPLICIT NONE
INTEGER, INTENT(IN) :: idx4, idx5, idx6, idx7
INTEGER, INTENT(IN) :: nx4 , nx5 , nx6
INTEGER, INTENT(IN) :: TypeSizeInBytes
INTEGER ,INTENT(IN ) :: DataHandle
CHARACTER*(*) ,INTENT(IN ) :: DateStr
CHARACTER*(*) ,INTENT(IN ) :: Var
INTEGER ,INTENT(IN ) :: Field(*)
INTEGER ,INTENT(IN ) :: FieldType
TYPE(domain) :: grid
INTEGER ,INTENT(IN ) :: DomainDesc
LOGICAL ,INTENT(IN ) :: dryrun
CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder
LOGICAL, DIMENSION(4) ,INTENT(IN ) :: bdy_mask
CHARACTER*(*) ,INTENT(IN ) :: Stagger
CHARACTER*(*) ,INTENT(IN ) :: Dimname1, Dimname2, Dimname3
CHARACTER*(*) ,INTENT(IN ) :: Desc, Units
CHARACTER*(*) ,INTENT(IN ) :: debug_message
INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, &
ms1, me1, ms2, me2, ms3, me3, &
ps1, pe1, ps2, pe2, ps3, pe3
INTEGER , INTENT(INOUT) :: Status
! Local
INTEGER tsfac ! Type size factor
CHARACTER*256 mess
tsfac = TypeSizeInBytes / IWORDSIZE
IF ( tsfac .LE. 0 ) THEN
CALL wrf_message('wrf_ext_write_field_arr')
WRITE(mess,*)'Internal error: email this message to [email protected] ',TypeSizeInBytes,IWORDSIZE
CALL wrf_error_fatal(mess)
ENDIF
CALL wrf_ext_write_field( DataHandle,DateStr,Var &
,Field(1 &
+tsfac*(0 &
+(idx4-1)*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) &
+(idx5-1)*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) &
+(idx6-1)*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) &
+(idx7-1)*nx6*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1))) &
,FieldType,grid &
,DomainDesc &
,bdy_mask &
,dryrun &
,MemoryOrder &
,Stagger &
,Dimname1, Dimname2, Dimname3 &
,Desc, Units &
,debug_message &
,ds1, de1, ds2, de2, ds3, de3 &
,ms1, me1, ms2, me2, ms3, me3 &
,ps1, pe1, ps2, pe2, ps3, pe3, Status )
END SUBROUTINE wrf_ext_write_field_arr
SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,grid, &
DomainDesc, &
bdy_mask , &
dryrun , &
MemoryOrder, &
Stagger, &
Dimname1, Dimname2, Dimname3 , &
Desc, Units, &
debug_message , &
ds1, de1, ds2, de2, ds3, de3, &
ms1, me1, ms2, me2, ms3, me3, &
ps1, pe1, ps2, pe2, ps3, pe3, Status )
USE module_io
USE module_wrf_error
USE module_state_description
USE module_timing
USE module_domain
IMPLICIT NONE
INTEGER ,INTENT(IN ) :: DataHandle
CHARACTER*(*) ,INTENT(IN ) :: DateStr
CHARACTER*(*) ,INTENT(IN ) :: Var
INTEGER ,INTENT(IN ) :: Field(*)
INTEGER ,INTENT(IN ) :: FieldType
TYPE(domain) :: grid
INTEGER ,INTENT(IN ) :: DomainDesc
LOGICAL ,INTENT(IN ) :: dryrun
CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder
LOGICAL, DIMENSION(4) ,INTENT(IN ) :: bdy_mask
CHARACTER*(*) ,INTENT(IN ) :: Stagger
CHARACTER*(*) ,INTENT(IN ) :: Dimname1, Dimname2, Dimname3
CHARACTER*(*) ,INTENT(IN ) :: Desc, Units
CHARACTER*(*) ,INTENT(IN ) :: debug_message
INTEGER , INTENT(IN ) :: ds1, de1, ds2, de2, ds3, de3, &
ms1, me1, ms2, me2, ms3, me3, &
ps1, pe1, ps2, pe2, ps3, pe3
! Local
INTEGER , DIMENSION(3) :: domain_start , domain_end
INTEGER , DIMENSION(3) :: memory_start , memory_end
INTEGER , DIMENSION(3) :: patch_start , patch_end
CHARACTER*80 , DIMENSION(3) :: dimnames
integer ,intent(inout) :: Status
LOGICAL for_out, horiz_stagger
INTEGER io_form
LOGICAL, EXTERNAL :: has_char
INTEGER, EXTERNAL :: use_package
INTEGER Hndl
IF ( wrf_at_debug_level( 500 ) ) THEN
call start_timing
ENDIF
domain_start(1) = ds1 ; domain_end(1) = de1 ;
patch_start(1) = ps1 ; patch_end(1) = pe1 ;
memory_start(1) = ms1 ; memory_end(1) = me1 ;
domain_start(2) = ds2 ; domain_end(2) = de2 ;
patch_start(2) = ps2 ; patch_end(2) = pe2 ;
memory_start(2) = ms2 ; memory_end(2) = me2 ;
domain_start(3) = ds3 ; domain_end(3) = de3 ;
patch_start(3) = ps3 ; patch_end(3) = pe3 ;
memory_start(3) = ms3 ; memory_end(3) = me3 ;
dimnames(1) = Dimname1
dimnames(2) = Dimname2
dimnames(3) = Dimname3
CALL debug_io_wrf ( debug_message,DateStr, &
domain_start,domain_end,patch_start,patch_end, &
memory_start,memory_end )
#if 0
Status = 1
if ( de1 - ds1 < 0 ) return
if ( de2 - ds2 < 0 ) return
if ( de3 - ds3 < 0 ) return
if ( pe1 - ps1 < 0 ) return
if ( pe2 - ps2 < 0 ) return
if ( pe3 - ps3 < 0 ) return
if ( me1 - ms1 < 0 ) return
if ( me2 - ms2 < 0 ) return
if ( me3 - ms3 < 0 ) return
#endif
Status = 0
CALL wrf_write_field ( &
DataHandle & ! DataHandle
,DateStr & ! DateStr
,Var & ! Data Name
,Field & ! Field
,FieldType & ! FieldType
,grid & ! grid
,DomainDesc & ! DomainDesc
,bdy_mask & ! bdy_mask
,MemoryOrder & ! MemoryOrder
,Stagger & ! JMMODS 010620
,dimnames & ! JMMODS 001109
,domain_start & ! DomainStart
,domain_end & ! DomainEnd
,memory_start & ! MemoryStart
,memory_end & ! MemoryEnd
,patch_start & ! PatchStart
,patch_end & ! PatchEnd
,Status )
CALL get_handle ( Hndl, io_form , for_out, DataHandle )
IF ( ( dryrun .AND. ( use_package(io_form) .EQ. IO_NETCDF .OR. &
use_package(io_form) .EQ. IO_NETCDFPAR .OR. &
use_package(io_form) .EQ. IO_PIO .OR. &
use_package(io_form) .EQ. IO_ADIOS2 .OR. &
use_package(io_form) .EQ. IO_PNETCDF ) ) .OR. &
( use_package(io_form) .EQ. IO_PHDF5 ) ) THEN
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"description" & ! Element
,Var & ! Data Name
,Desc & ! Data
,Status )
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"units" & ! Element
,Var & ! Data Name
,Units & ! Data
,Status )
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"stagger" & ! Element
,Var & ! Data Name
,Stagger & ! Data
,Status )
#if (EM_CORE == 1)
! TBH: Added "coordinates" metadata for GIS folks in RAL. It is a step
! TBH: towards CF. This change was requested by Jennifer Boehnert based
! TBH: upon a suggestion from Nawajish Noman.
! TBH: TODO: This code depends upon longitude and latitude arrays being
! TBH: named "XLONG", "XLAT", "XLONG_U", "XLAT_U", "XLONG_V", and
! TBH: "XLAT_V" for EM_CORE. We need a more general way to handle
! TBH: this, possibly via the Registry.
! TBH: TODO: Use dimnames(*) == south_north || west_east instead of
! TBH: MemoryOrder and Stagger?
IF ( ( TRIM(MemoryOrder) == 'XY' ) .AND. &
( ( TRIM(Var) == 'XLONG' ) .OR. &
( TRIM(Var) == 'XLAT' ) .OR. &
( TRIM(Var) == 'XLONG_U' ) .OR. &
( TRIM(Var) == 'XLAT_U' ) .OR. &
( TRIM(Var) == 'XLONG_V' ) .OR. &
( TRIM(Var) == 'XLAT_V' ) ) ) THEN
horiz_stagger = .FALSE.
IF ( LEN_TRIM(Stagger) == 1 ) THEN
IF ( has_char( Stagger, 'x' ) ) THEN
horiz_stagger = .TRUE.
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"coordinates" & ! Element
,Var & ! Data Name
,"XLONG_U XLAT_U" & ! Data
,Status )
ELSE IF ( has_char( Stagger, 'y' ) ) THEN
horiz_stagger = .TRUE.
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"coordinates" & ! Element
,Var & ! Data Name
,"XLONG_V XLAT_V" & ! Data
,Status )
ENDIF
ENDIF
IF ( .NOT. horiz_stagger ) THEN
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"coordinates" & ! Element
,Var & ! Data Name
,"XLONG XLAT" & ! Data
,Status )
ENDIF
ELSE IF ( ( TRIM(MemoryOrder) == 'XY' ) .OR. &
( TRIM(MemoryOrder) == 'XZY' ) .OR. &
( TRIM(MemoryOrder) == 'XYZ' ) ) THEN
horiz_stagger = .FALSE.
IF ( LEN_TRIM(Stagger) == 1 ) THEN
IF ( has_char( Stagger, 'x' ) ) THEN
horiz_stagger = .TRUE.
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"coordinates" & ! Element
,Var & ! Data Name
,"XLONG_U XLAT_U XTIME" & ! Data
,Status )
ELSE IF ( has_char( Stagger, 'y' ) ) THEN
horiz_stagger = .TRUE.
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"coordinates" & ! Element
,Var & ! Data Name
,"XLONG_V XLAT_V XTIME" & ! Data
,Status )
ENDIF
ENDIF
IF ( .NOT. horiz_stagger ) THEN
CALL wrf_put_var_ti_char( &
DataHandle & ! DataHandle
,"coordinates" & ! Element
,Var & ! Data Name
,"XLONG XLAT XTIME" & ! Data
,Status )
ENDIF
ENDIF
#endif
ENDIF
IF ( wrf_at_debug_level(300) ) THEN
WRITE(wrf_err_message,*) debug_message,' Status = ',Status
CALL wrf_message ( TRIM(wrf_err_message) )
ENDIF
IF ( wrf_at_debug_level( 500 ) ) THEN
CALL end_timing('wrf_ext_write_field')
ENDIF
END SUBROUTINE wrf_ext_write_field