gen_wrf_io.c
References to this file elsewhere.
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <string.h>
4 #include <strings.h>
5
6 #include "protos.h"
7 #include "registry.h"
8 #include "data.h"
9 #include "sym.h"
10
11 static FILE * fp ;
12
13 #define GEN_INPUT 1
14 #define GEN_OUTPUT 2
15
16 #define OP_F(A,B) \
17 fn = B ; \
18 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } \
19 else { sprintf(fname,"%s",fn) ; } \
20 if ((A = fopen( fname , "w" )) == NULL ) return(1) ; \
21 print_warning(A,fname) ; \
22 sym_forget() ;
23
24 int
25 gen_wrf_io ( char * dirname )
26 {
27 char fname[NAMELEN], *fn ;
28
29 if ( dirname == NULL ) return(1) ;
30
31 #if 1
32
33 OP_F(fp,"wrf_metaput_input.inc") ;
34 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
35 METADATA | INPUT , GEN_OUTPUT ) ;
36
37 OP_F(fp,"wrf_metaput_restart.inc") ;
38 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
39 METADATA | RESTART , GEN_OUTPUT ) ;
40
41 OP_F(fp,"wrf_metaput_history.inc") ;
42 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
43 METADATA | HISTORY , GEN_OUTPUT ) ;
44
45 OP_F(fp,"wrf_metaput_boundary.inc") ;
46 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
47 METADATA | BOUNDARY , GEN_OUTPUT ) ;
48
49 OP_F(fp,"wrf_histout.inc") ;
50 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_OUTPUT ) ;
51 close_the_file(fp) ;
52 OP_F(fp,"wrf_auxhist1out.inc") ;
53 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_OUTPUT ) ;
54 close_the_file(fp) ;
55 OP_F(fp,"wrf_auxhist2out.inc") ;
56 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_OUTPUT ) ;
57 close_the_file(fp) ;
58 OP_F(fp,"wrf_auxhist3out.inc") ;
59 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_OUTPUT ) ;
60 close_the_file(fp) ;
61 OP_F(fp,"wrf_auxhist4out.inc") ;
62 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_OUTPUT ) ;
63 close_the_file(fp) ;
64 OP_F(fp,"wrf_auxhist5out.inc") ;
65 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_OUTPUT ) ;
66 close_the_file(fp) ;
67 OP_F(fp,"wrf_auxhist6out.inc") ;
68 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_OUTPUT ) ;
69 close_the_file(fp) ;
70 OP_F(fp,"wrf_auxhist7out.inc") ;
71 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_OUTPUT ) ;
72 close_the_file(fp) ;
73 OP_F(fp,"wrf_auxhist8out.inc") ;
74 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_OUTPUT ) ;
75 close_the_file(fp) ;
76 OP_F(fp,"wrf_auxhist9out.inc") ;
77 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_OUTPUT ) ;
78 close_the_file(fp) ;
79 OP_F(fp,"wrf_auxhist10out.inc") ;
80 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_OUTPUT ) ;
81 close_the_file(fp) ;
82 OP_F(fp,"wrf_auxhist11out.inc") ;
83 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_OUTPUT ) ;
84 close_the_file(fp) ;
85
86 OP_F(fp,"wrf_inputout.inc") ;
87 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_OUTPUT ) ;
88 close_the_file(fp) ;
89 OP_F(fp,"wrf_auxinput1out.inc") ;
90 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_OUTPUT ) ;
91 close_the_file(fp) ;
92 OP_F(fp,"wrf_auxinput2out.inc") ;
93 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_OUTPUT ) ;
94 close_the_file(fp) ;
95 OP_F(fp,"wrf_auxinput3out.inc") ;
96 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_OUTPUT ) ;
97 close_the_file(fp) ;
98 OP_F(fp,"wrf_auxinput4out.inc") ;
99 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_OUTPUT ) ;
100 close_the_file(fp) ;
101 OP_F(fp,"wrf_auxinput5out.inc") ;
102 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_OUTPUT ) ;
103 close_the_file(fp) ;
104 OP_F(fp,"wrf_auxinput6out.inc") ;
105 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_OUTPUT ) ;
106 close_the_file(fp) ;
107 OP_F(fp,"wrf_auxinput7out.inc") ;
108 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_OUTPUT ) ;
109 close_the_file(fp) ;
110 OP_F(fp,"wrf_auxinput8out.inc") ;
111 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_OUTPUT ) ;
112 close_the_file(fp) ;
113 OP_F(fp,"wrf_auxinput9out.inc") ;
114 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_OUTPUT ) ;
115 close_the_file(fp) ;
116 OP_F(fp,"wrf_auxinput10out.inc") ;
117 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_OUTPUT ) ;
118 close_the_file(fp) ;
119 OP_F(fp,"wrf_auxinput11out.inc") ;
120 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_OUTPUT ) ;
121 close_the_file(fp) ;
122 OP_F(fp,"wrf_restartout.inc") ;
123 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_OUTPUT ) ;
124 close_the_file(fp) ;
125 OP_F(fp,"wrf_bdyout.inc") ;
126 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_OUTPUT ) ;
127 close_the_file(fp) ;
128 #endif
129
130 #if 1
131 OP_F(fp,"wrf_metaget_input.inc") ;
132 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
133 METADATA | INPUT , GEN_INPUT ) ;
134
135 OP_F(fp,"wrf_metaget_restart.inc") ;
136 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
137 METADATA | RESTART , GEN_INPUT ) ;
138
139 OP_F(fp,"wrf_metaget_history.inc") ;
140 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
141 METADATA | HISTORY , GEN_INPUT ) ;
142
143 OP_F(fp,"wrf_metaget_boundary.inc") ;
144 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields ,
145 METADATA | BOUNDARY , GEN_INPUT ) ;
146
147 OP_F(fp,"wrf_histin.inc") ;
148 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , HISTORY , GEN_INPUT ) ;
149 close_the_file(fp) ;
150 OP_F(fp,"wrf_auxhist1in.inc") ;
151 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST1 , GEN_INPUT ) ;
152 close_the_file(fp) ;
153 OP_F(fp,"wrf_auxhist2in.inc") ;
154 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST2 , GEN_INPUT ) ;
155 close_the_file(fp) ;
156 OP_F(fp,"wrf_auxhist3in.inc") ;
157 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST3 , GEN_INPUT ) ;
158 close_the_file(fp) ;
159 OP_F(fp,"wrf_auxhist4in.inc") ;
160 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST4 , GEN_INPUT ) ;
161 close_the_file(fp) ;
162 OP_F(fp,"wrf_auxhist5in.inc") ;
163 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST5 , GEN_INPUT ) ;
164 close_the_file(fp) ;
165 OP_F(fp,"wrf_auxhist6in.inc") ;
166 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST6 , GEN_INPUT ) ;
167 close_the_file(fp) ;
168 OP_F(fp,"wrf_auxhist7in.inc") ;
169 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST7 , GEN_INPUT ) ;
170 close_the_file(fp) ;
171 OP_F(fp,"wrf_auxhist8in.inc") ;
172 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST8 , GEN_INPUT ) ;
173 close_the_file(fp) ;
174 OP_F(fp,"wrf_auxhist9in.inc") ;
175 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST9 , GEN_INPUT ) ;
176 close_the_file(fp) ;
177 OP_F(fp,"wrf_auxhist10in.inc") ;
178 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST10 , GEN_INPUT ) ;
179 close_the_file(fp) ;
180 OP_F(fp,"wrf_auxhist11in.inc") ;
181 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXHIST11 , GEN_INPUT ) ;
182 close_the_file(fp) ;
183 OP_F(fp,"wrf_inputin.inc") ;
184 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , INPUT , GEN_INPUT ) ;
185 close_the_file(fp) ;
186 OP_F(fp,"wrf_auxinput1in.inc") ;
187 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT1 , GEN_INPUT ) ;
188 close_the_file(fp) ;
189 OP_F(fp,"wrf_auxinput2in.inc") ;
190 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT2 , GEN_INPUT ) ;
191 close_the_file(fp) ;
192 OP_F(fp,"wrf_auxinput3in.inc") ;
193 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT3 , GEN_INPUT ) ;
194 close_the_file(fp) ;
195 OP_F(fp,"wrf_auxinput4in.inc") ;
196 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT4 , GEN_INPUT ) ;
197 close_the_file(fp) ;
198 OP_F(fp,"wrf_auxinput5in.inc") ;
199 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT5 , GEN_INPUT ) ;
200 close_the_file(fp) ;
201 OP_F(fp,"wrf_auxinput6in.inc") ;
202 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT6 , GEN_INPUT ) ;
203 close_the_file(fp) ;
204 OP_F(fp,"wrf_auxinput7in.inc") ;
205 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT7 , GEN_INPUT ) ;
206 close_the_file(fp) ;
207 OP_F(fp,"wrf_auxinput8in.inc") ;
208 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT8 , GEN_INPUT ) ;
209 close_the_file(fp) ;
210 OP_F(fp,"wrf_auxinput9in.inc") ;
211 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT9 , GEN_INPUT ) ;
212 close_the_file(fp) ;
213 OP_F(fp,"wrf_auxinput10in.inc") ;
214 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT10 , GEN_INPUT ) ;
215 close_the_file(fp) ;
216 OP_F(fp,"wrf_auxinput11in.inc") ;
217 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , AUXINPUT11 , GEN_INPUT ) ;
218 close_the_file(fp) ;
219 OP_F(fp,"wrf_restartin.inc") ;
220 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , RESTART , GEN_INPUT ) ;
221 close_the_file(fp) ;
222 OP_F(fp,"wrf_bdyin.inc") ;
223 gen_wrf_io2 ( fp , fname, "grid%" , NULL, Domain.fields , BOUNDARY , GEN_INPUT ) ;
224 close_the_file(fp) ;
225 #endif
226
227 return(0) ;
228 }
229
230 static int
231 set_dim_strs_x ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag, int sw_reorder )
232 {
233 int i, j, ii ;
234 node_t *p ;
235 char d, d1 ;
236 char * stag ;
237 char r1[NAMELEN] ;
238
239 strcpy(r1,"grid%") ;
240 if ( node == NULL ) return(1) ;
241 for ( i = 0 ; i < 3 ; i++ )
242 for ( j = 0 ; j < 2 ; j++ )
243 {
244 strcpy(ddim[i][j],"1") ;
245 strcpy(mdim[i][j],"1") ;
246 strcpy(pdim[i][j],"1") ;
247 }
248
249 for ( ii = 0 ; ii < node->ndims ; ii++ )
250 {
251 p = node->dims[ii] ;
252 if ( sw_reorder ) {
253 i = ii ;
254 } else {
255 switch( p->coord_axis )
256 {
257 case(COORD_X) : i = 0 ; break ;
258 case(COORD_Y) : i = 2 ; break ;
259 case(COORD_Z) : i = 1 ; break ;
260 default : break ;
261 }
262 }
263 if ( p->len_defined_how == DOMAIN_STANDARD )
264 {
265 if ( p->subgrid ) {
266 switch( p->coord_axis )
267 {
268 case(COORD_X) : d = 'i' ; d1 = 'x' ; break ;
269 case(COORD_Y) : d = 'j' ; d1 = 'y' ; break ;
270 case(COORD_Z) : d = 'k' ; d1 = 'z' ; break ;
271 default : break ;
272 }
273
274 sprintf(ddim[i][0],"%s%cds",prepend,d) ;
275 sprintf(ddim[i][1],"%s%cde * %ssr_%c ",prepend,d,r1,d1) ;
276 sprintf(mdim[i][0],"(%s%cms-1)*%ssr_%c+1",prepend,d,r1,d1) ;
277 sprintf(mdim[i][1],"%s%cme*%ssr_%c",prepend,d,r1,d1) ;
278 sprintf(pdim[i][0],"(%s%cps-1)*%ssr_%c+1",prepend,d,r1,d1) ;
279 sprintf(pdim[i][1],"%s%cpe*%ssr_%c",prepend,d,r1,d1) ;
280
281 } else {
282 if ( sw_3dvar_iry_kludge ) {
283 switch( p->coord_axis )
284 {
285 /* vvv */
286 case(COORD_X) : d = 'i' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
287 case(COORD_Y) : d = 'j' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
288 /* ^^^ */
289 case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
290 default : stag = "1" ; break ;
291 }
292 } else {
293 switch( p->coord_axis )
294 {
295 case(COORD_X) : d = 'i' ; stag = (node->stag_x||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
296 case(COORD_Y) : d = 'j' ; stag = (node->stag_y||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
297 case(COORD_Z) : d = 'k' ; stag = (node->stag_z||sw_disregard_stag)?"%s%cde":"(%s%cde-1)" ; break ;
298 default : stag = "1" ; break ;
299 }
300 }
301
302 sprintf(ddim[i][0],"%s%cds",prepend,d) ;
303 sprintf(ddim[i][1],stag,prepend,d) ; /* note that stag has printf format info in it */
304 sprintf(mdim[i][0],"%s%cms",prepend,d) ;
305 sprintf(mdim[i][1],"%s%cme",prepend,d) ;
306 sprintf(pdim[i][0],"%s%cps",prepend,d) ;
307 if ( ! sw_disregard_stag )
308 sprintf(pdim[i][1],"MIN( %s, %s%cpe )",ddim[i][1],prepend,d) ;
309 else
310 sprintf(pdim[i][1],"%s%cpe",prepend,d) ;
311 }
312 }
313 else if ( p->len_defined_how == NAMELIST )
314 {
315 if ( !strcmp( p->assoc_nl_var_s, "1" ) )
316 {
317 sprintf(ddim[i][0],"1") ;
318 sprintf(mdim[i][0],"1") ;
319 sprintf(pdim[i][0],"1") ;
320 }
321 else
322 {
323 sprintf(ddim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ;
324 sprintf(mdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ;
325 sprintf(pdim[i][0],"config_flags%%%s",p->assoc_nl_var_s) ;
326 }
327 sprintf(ddim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ;
328 sprintf(mdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ;
329 sprintf(pdim[i][1],"config_flags%%%s",p->assoc_nl_var_e) ;
330 }
331 else if ( p->len_defined_how == CONSTANT )
332 {
333 sprintf(ddim[i][0],"%d",p->coord_start ) ;
334 sprintf(ddim[i][1],"%d",p->coord_end ) ;
335 sprintf(mdim[i][0],"%d",p->coord_start ) ;
336 sprintf(mdim[i][1],"%d",p->coord_end ) ;
337 sprintf(pdim[i][0],"%d",p->coord_start ) ;
338 sprintf(pdim[i][1],"%d",p->coord_end ) ;
339 }
340 }
341 return(0) ;
342 }
343
344
345 int
346 set_dim_strs ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag )
347 {
348 set_dim_strs_x ( node , ddim, mdim, pdim, prepend , sw_disregard_stag, 1 ) ; /* 1 = reorder according to strg order */
349 }
350
351 /* version that doesn't permute according to index order -- always i, k, then j
352 useful for standard argument lists -- e.g. calls to interp in nesting */
353 int
354 set_dim_strs2 ( node_t *node , char ddim[3][2][NAMELEN], char mdim[3][2][NAMELEN], char pdim[3][2][NAMELEN] , char * prepend , int sw_disregard_stag )
355 {
356 set_dim_strs_x ( node , ddim, mdim, pdim, prepend , sw_disregard_stag, 0 ) ; /* 0 = reorder according to strg order */
357 }
358
359 int
360 gen_wrf_io2 ( FILE * fp , char * fname, char * structname , char * fourdname, node_t * node , int io_mask , int sw_io )
361 {
362 node_t * p ;
363 int i , ii ;
364 char x[NAMELEN], tag[NAMELEN], dexes[NAMELEN] ;
365 char dname[NAMELEN], dname_tmp[NAMELEN] ;
366 char vname[NAMELEN], vname_x[NAMELEN],vname_1[NAMELEN], vname_2[NAMELEN], memord[NAMELEN] ;
367 char ddim[3][2][NAMELEN] ;
368 char mdim[3][2][NAMELEN] ;
369 char pdim[3][2][NAMELEN] ;
370 char ddim_no[3][2][NAMELEN] ;
371 char mdim_no[3][2][NAMELEN] ;
372 char pdim_no[3][2][NAMELEN] ;
373 char dimname[3][NAMELEN] ;
374 char core[NAMELEN] ;
375 char stagstr[NAMELEN] ;
376 char * tend_tag ;
377
378 char post[NAMELEN] ;
379 char indices[NAMELEN] ;
380
381 int pass, passes, stagx, stagy, stagz ;
382 int xi, yi, zi ;
383 node_t * dimnode ;
384 int ok_to_collect_distribute ;
385
386 /* set a flag according to what the stream is, if we're running on dm processors, if the
387 io layer cannot handle distributed data, and if we're selectively turning off the
388 collect/distribute message passing so that history and restart I/O is to separate files
389 but input and boundary I/O is unaffected */
390
391 ok_to_collect_distribute = !sw_distrib_io_layer &&
392 sw_dm_parallel &&
393 !(sw_dm_serial_in_only && ((io_mask&HISTORY) ||
394 (io_mask&AUXHIST1) ||
395 (io_mask&AUXHIST2) ||
396 (io_mask&AUXHIST3) ||
397 (io_mask&AUXHIST4) ||
398 (io_mask&AUXHIST5) ||
399 (io_mask&AUXHIST6) ||
400 (io_mask&AUXHIST7) ||
401 (io_mask&AUXHIST8) ||
402 (io_mask&AUXHIST9) ||
403 (io_mask&AUXHIST10) ||
404 (io_mask&AUXHIST11) ||
405 (io_mask&RESTART))) ;
406
407 if ( node == NULL ) return(1) ;
408 if ( structname == NULL ) return(1) ;
409 if ( fp == NULL ) return(1) ;
410
411 for ( p = node ; p != NULL ; p = p->next )
412 {
413
414 if ( p->ndims > 3 ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */
415
416 if ( p->node_kind & I1 ) continue ; /* short circuit anything that's not a state var */
417
418 set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */
419 set_dim_strs( p, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */
420
421 strcpy(stagstr, "") ;
422 if ( p->stag_x ) strcat(stagstr, "X") ;
423 if ( p->stag_y ) strcat(stagstr, "Y") ;
424 if ( p->stag_z ) strcat(stagstr, "Z") ;
425
426 if ( !strcmp(p->name,"-") ) continue ;
427
428 if ( p->node_kind & FOURD )
429 {
430 node_t * nd , *pp ;
431 char p1[NAMELEN], sv[NAMELEN], tl[25] ;
432
433 set_dim_strs( p->members, ddim, mdim, pdim , "", 0 ) ; /* dimensions with staggering */
434 set_dim_strs( p->members, ddim_no, mdim_no, pdim_no , "", 1 ) ; /* dimensions ignoring staggering */
435
436 if ( ! ( io_mask & BOUNDARY ) )
437 {
438 set_mem_order( p->members, memord , NAMELEN) ;
439 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
440 fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
441 #if DA_CORE==1
442 fprintf(fp," IF (.not. ((%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM_TL) .or. &\n",p->name);
443 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM) .or. &\n",p->name);
444 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'G_' .and. grid%%dyn_opt == DYN_EM))) THEN\n" ,p->name);
445 #endif
446 fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
447 fprintf(fp," fid , & ! DataHandle\n") ;
448 fprintf(fp," current_date(1:19) , & ! DateStr\n") ;
449 fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ;
450 strcpy( tl, "" ) ;
451 if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ;
452 if ( ok_to_collect_distribute ) {
453 fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ;
454 } else {
455 if ( !strcmp(memord,"XYZ") ) {
456 fprintf(fp," grid%%%s%s(ims,jms,kms,itrace) , & ! Field\n",p->name,tl) ;
457 } else if ( !strcmp(memord,"YXZ") ) {
458 fprintf(fp," grid%%%s%s(jms,ims,kms,itrace) , & ! Field\n",p->name,tl) ;
459 } else if ( !strcmp(memord,"XZY") ) {
460 fprintf(fp," grid%%%s%s(ims,kms,jms,itrace) , & ! Field\n",p->name,tl) ;
461 } else if ( !strcmp(memord,"YZX") ) {
462 fprintf(fp," grid%%%s%s(jms,kms,ims,itrace) , & ! Field\n",p->name,tl) ;
463 } else if ( !strcmp(memord,"ZXY") ) {
464 fprintf(fp," grid%%%s%s(kms,ims,jms,itrace) , & ! Field\n",p->name,tl) ;
465 } else if ( !strcmp(memord,"ZYX") ) {
466 fprintf(fp," grid%%%s%s(kms,jms,ims,itrace) , & ! Field\n",p->name,tl) ;
467 }
468 }
469 if (!strncmp(p->members->type->name,"real",4)) {
470 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
471 } else {
472 fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ;
473 }
474 fprintf(fp," grid%%communicator , & ! Comm\n") ;
475 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
476 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
477 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
478 if ( sw_io == GEN_OUTPUT ) {
479 fprintf(fp," dryrun , & ! flag\n") ;
480 }
481 fprintf(stderr,"name %s memord %s\n",p->name,memord) ;
482 fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ;
483 strcpy(stagstr, "") ;
484 if ( p->members->stag_x ) strcat(stagstr, "X") ;
485 if ( p->members->stag_y ) strcat(stagstr, "Y") ;
486 if ( p->members->stag_z ) strcat(stagstr, "Z") ;
487 fprintf(fp," '%s' , & ! Stagger\n",stagstr) ;
488 if ( sw_io == GEN_OUTPUT ) {
489 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
490 for ( i = 0 ; i < 3 ; i++ )
491 {
492 if (( dimnode = p->members->dims[i]) != NULL )
493 {
494 switch ( dimnode->coord_axis )
495 {
496 case (COORD_X) :
497 if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) )
498 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
499 else
500 { strcpy( dimname[i], dimnode->dim_data_name) ; }
501 break ;
502 case (COORD_Y) :
503 if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) )
504 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
505 else
506 { strcpy( dimname[i], dimnode->dim_data_name) ; }
507 break ;
508 case (COORD_Z) :
509 if ( p->members->stag_z )
510 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
511 else
512 { strcpy( dimname[i], dimnode->dim_data_name) ; }
513 break ;
514 }
515 }
516 }
517 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
518 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
519 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
520 fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ;
521 fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ;
522 }
523 fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name, memord ) ;
524 /* global dimensions */
525 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
526 fprintf(fp," & \n") ;
527 /* mem dimensions */
528 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
529 fprintf(fp," & \n") ;
530 /* patch dimensions */
531 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
532 fprintf(fp," & \n") ;
533 fprintf(fp," ierr )\n" ) ;
534 #if DA_CORE==1
535 fprintf(fp, " ENDIF\n" ) ;
536 #endif
537 fprintf(fp, " ENDIF\n" ) ;
538 fprintf(fp, "ENDDO\n") ;
539 }
540 /* BOUNDARY FOR 4-D TRACER */
541 else if ( io_mask & BOUNDARY )
542 {
543 int ibdy ;
544 int idx ;
545 node_t *fourd_bound_array ;
546 char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ;
547 char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
548
549 /* check for the existence of a fourd boundary array */
550 sprintf(fourd_bnd,"%s_b",p->name) ;
551 if (( fourd_bound_array = get_entry( fourd_bnd ,Domain.fields)) != NULL ) {
552
553 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
554 strcpy( dimname[2] , "bdy_width" ) ;
555 ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
556 ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
557 ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
558 if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
559 { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; }
560 else { strcpy( dimname[1], dimnode->dim_data_name) ; }
561 if ( p->stag_z ) { zdomainend = "kde" ; }
562 else { zdomainend = "(kde-1)" ; }
563 ds2 = "kds" ; de2 = zdomainend ;
564 ms2 = "kds" ; me2 = "kde" ; /* 20020924 */
565 ps2 = "kds" ; pe2 = zdomainend ;
566 }
567 else
568 {
569 fprintf(stderr,"REGISTRY WARNING: 4D ARRAYS MUST HAVE VERT DIMENSION\n") ;
570 }
571 for ( pass = 0 ; pass < 2 ; pass++ ) {
572 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
573 fprintf(fp," IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
574 #if DA_CORE==1
575 fprintf(fp," IF (.not. ((%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM_TL) .or. &\n",p->name);
576 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'A_' .and. grid%%dyn_opt == DYN_EM) .or. &\n",p->name);
577 fprintf(fp," (%s_dname_table( grid%%id, itrace )(1:2) == 'G_' .and. grid%%dyn_opt == DYN_EM))) THEN\n" ,p->name);
578 #endif
579 for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
580 {
581 if ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ; /* west bdy */
582 } else if ( pass == 0 && ibdy == 2 ) { bdytag = "_BXE" ; /* east bdy */
583 } else if ( pass == 0 && ibdy == 3 ) { bdytag = "_BYS" ; /* south bdy */
584 } else if ( pass == 0 && ibdy == 4 ) { bdytag = "_BYE" ; /* north bdy */
585 } else if ( pass == 1 && ibdy == 1 ) { bdytag = "_BTXS" ; /* west bdy */
586 } else if ( pass == 1 && ibdy == 2 ) { bdytag = "_BTXE" ; /* east bdy */
587 } else if ( pass == 1 && ibdy == 3 ) { bdytag = "_BTYS" ; /* south bdy */
588 } else if ( pass == 1 && ibdy == 4 ) { bdytag = "_BTYE" ; /* north bdy */
589 }
590 if ( ibdy == 1 || ibdy == 2 ) {
591 if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
592 {
593 idx = get_index_for_coord( p , COORD_Y ) ;
594 if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
595 ds1 = "1" ; de1 = ydomainend ;
596 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
597 if ( sw_new_bdys ) { /* 20070207 */
598 if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; }
599 if ( sw_io == GEN_INPUT ) {
600 ps1 = "MAX(jms,jds)" ;
601 sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ;
602 } else if ( sw_io == GEN_OUTPUT ) {
603 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
604 }
605 } else {
606 if ( sw_io == GEN_INPUT ) {
607 ps1 = "1" ; pe1 = ydomainend ;
608 } else if ( sw_io == GEN_OUTPUT ) {
609 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
610 }
611 }
612 if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
613 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
614 }
615 }
616 if ( ibdy == 3 || ibdy == 4 ) {
617 if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
618 {
619 idx = get_index_for_coord( p , COORD_X ) ;
620 if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
621 ds1 = "1" ; de1 = xdomainend ;
622 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
623 if ( sw_new_bdys ) { /* 20070207 */
624 if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; }
625 if ( sw_io == GEN_INPUT ) {
626 ps1 = "MAX(ims,ids)" ;
627 sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ;
628 } else if ( sw_io == GEN_OUTPUT ) {
629 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
630 }
631 } else {
632 if ( sw_io == GEN_INPUT ) {
633 ps1 = "1" ; pe1 = xdomainend ;
634 } else if ( sw_io == GEN_OUTPUT ) {
635 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
636 }
637 }
638 if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
639 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
640 }
641 }
642 if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag+2+pass ) ;
643 else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag+2+pass ) ;
644 else sprintf(memord,"0") ;
645 fprintf(fp," CALL wrf_ext_%s_field ( &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
646 fprintf(fp," fid , & ! DataHandle\n") ;
647 fprintf(fp," current_date(1:19) , & ! DateStr\n") ;
648 fprintf(fp," TRIM(%s_dname_table( grid%%id, itrace )) // '%s', & !data name\n",p->name,bdytag) ;
649 if ( ok_to_collect_distribute ) {
650 fprintf(fp," globbuf_%s , & ! Field \n",p->members->type->name ) ;
651 } else {
652 strcpy(bdytag2,"") ;
653 strncat(bdytag2,bdytag, pass+2) ;
654 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
655 fprintf(fp," grid%%%s%s(%s,kds,1,itrace) , & ! Field\n",p->name,bdytag, ms1) ;
656 } else {
657 fprintf(fp," grid%%%s%s(1,kds,1,%d,itrace) , & ! Field\n",p->name,bdytag2, ibdy) ;
658 }
659 }
660 if (!strncmp(p->members->type->name,"real",4)) {
661 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
662 } else {
663 fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ;
664 }
665 fprintf(fp," grid%%communicator , & ! Comm\n") ;
666 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
667 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
668 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
669 if ( sw_io == GEN_OUTPUT ) {
670 fprintf(fp," dryrun , & ! flag\n") ;
671 }
672 fprintf(fp," '%s' , & ! MemoryOrder\n",memord) ;
673 strcpy(stagstr, "") ;
674 if ( p->members->stag_x ) strcat(stagstr, "X") ;
675 if ( p->members->stag_y ) strcat(stagstr, "Y") ;
676 if ( p->members->stag_z ) strcat(stagstr, "Z") ;
677 fprintf(fp," '%s' , & ! Stagger\n",stagstr) ;
678 if ( sw_io == GEN_OUTPUT ) {
679 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
680 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
681 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
682 fprintf(fp," %s_desc_table( grid%%id, itrace ), & ! Desc\n",p->name) ;
683 fprintf(fp," %s_units_table( grid%%id, itrace ), & ! Units\n",p->name) ;
684 }
685 fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name,memord ) ;
686 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
687 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
688 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
689 fprintf(fp," ierr )\n" ) ;
690 }
691 #if DA_CORE==1
692 fprintf(fp, " ENDIF\n" ) ;
693 #endif
694 fprintf(fp, " ENDIF\n" ) ;
695 fprintf(fp, "ENDDO\n") ;
696 }
697 }
698 } /* if fourd bound array associated with this tracer */
699 }
700 else if ( p->type != NULL )
701 {
702
703 if ( p->type->type == SIMPLE )
704 {
705
706 /* //////// BOUNDARY ///////////////////// */
707
708 if ( p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA )
709 && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) )
710 {
711 int ibdy ;
712 int idx ;
713 char *bdytag, *xdomainend, *ydomainend, *zdomainend ;
714 char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
715 char t1[64], t2[64] ;
716
717 if (!strncmp( p->use, "dyn_", 4))
718 sprintf(core,"%s_",p->use+4) ;
719 else
720 strcpy(core,"") ;
721
722 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
723 strcpy( dimname[2] , "bdy_width" ) ;
724 ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
725 ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
726 ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
727
728 if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
729 { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; }
730 else { strcpy( dimname[1], dimnode->dim_data_name) ; }
731 if ( p->stag_z ) { zdomainend = "kde" ; }
732 else { zdomainend = "(kde-1)" ; }
733 ds2 = "kds" ; de2 = zdomainend ;
734 ms2 = "kds" ; me2 = "kde" ; /* 20020924 */
735 ps2 = "kds" ; pe2 = zdomainend ;
736 }
737 else
738 { strcpy(dimname[1],dimname[2]) ;
739 strcpy(dimname[2],"one_element") ;
740 ds2 = ds3 ; de2 = de3 ;
741 ms2 = ms3 ; me2 = me3 ;
742 ps2 = ps3 ; pe2 = pe3 ;
743 ds3 = "1" ; de3 = "1" ;
744 ms3 = "1" ; me3 = "1" ;
745 ps3 = "1" ; pe3 = "1" ;
746 }
747
748 if ( strlen(p->dname) < 1 ) {
749 fprintf(stderr,"gen_wrf_io.c: Registry WARNING: no data name for %s \n",p->name) ;
750 }
751
752 for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
753 {
754 if ( ibdy == 1 ) { bdytag = "XS" ; /* west bdy */
755 } else if ( ibdy == 2 ) { bdytag = "XE" ; /* east bdy */
756 } else if ( ibdy == 3 ) { bdytag = "YS" ; /* south bdy */
757 } else if ( ibdy == 4 ) { bdytag = "YE" ; /* north bdy */
758 }
759 if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s",p->name,bdytag) ; }
760 else { sprintf(dname,"%s%s",p->dname,bdytag) ; }
761
762 make_upper_case(dname) ;
763
764 if ( ibdy == 1 || ibdy == 2 ) {
765 if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
766 {
767 idx = get_index_for_coord( p , COORD_Y ) ;
768 if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
769 ds1 = "1" ; de1 = ydomainend ;
770 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
771 if ( sw_new_bdys ) { /* 20070207 */
772 if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; }
773 if ( sw_io == GEN_INPUT ) {
774 ps1 = "MAX(jms,jds)" ;
775 sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ;
776 } else if ( sw_io == GEN_OUTPUT ) {
777 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
778 }
779 } else {
780 if ( sw_io == GEN_INPUT ) {
781 ps1 = "1" ; pe1 = ydomainend ;
782 } else if ( sw_io == GEN_OUTPUT ) {
783 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
784 }
785 }
786 if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
787 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
788 }
789 }
790 if ( ibdy == 3 || ibdy == 4 ) {
791 if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
792 {
793 idx = get_index_for_coord( p , COORD_X ) ;
794 if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
795 ds1 = "1" ; de1 = xdomainend ;
796 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
797 if ( sw_new_bdys ) { /* 20070207 */
798 if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; }
799 if ( sw_io == GEN_INPUT ) {
800 ps1 = "MAX(ims,ids)" ;
801 sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ;
802 } else if ( sw_io == GEN_OUTPUT ) {
803 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
804 }
805 } else {
806 ms1 = "1" ; me1 = "MAX( ide , jde )" ;
807 if ( sw_io == GEN_INPUT ) {
808 ps1 = "1" ; pe1 = xdomainend ;
809 } else if ( sw_io == GEN_OUTPUT ) {
810 ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
811 }
812 }
813 if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
814 else { strcpy( dimname[0], dimnode->dim_data_name) ; }
815 }
816 }
817 if ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag ) ;
818 else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag ) ;
819 else sprintf(memord,"0") ;
820
821 passes = 1 ;
822 if ( fourdname != NULL ) passes = 2 ;
823 for ( pass = 0 ; pass < passes ; pass++ ) {
824 tend_tag = ( pass == 0 ) ? "_B" : "_BT" ;
825 if ( sw_io == GEN_INPUT )
826 {
827 if ( !strncmp( p->use, "dyn_", 4 ) )
828 #if DA_CORE==1
829 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
830 if ( !strncmp(dname, "A_", 2) ) {
831 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
832 }
833 else if ( !strncmp(dname, "G_", 2) ) {
834 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
835 }
836 #else
837 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
838 #endif
839 if ( ok_to_collect_distribute )
840 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
841 fprintf(fp,"CALL wrf_ext_read_field ( &\n") ;
842 fprintf(fp," fid , & ! DataHandle \n" ) ;
843 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
844 if ( fourdname == NULL ) {
845 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
846 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
847 fprintf(fp," %s%s%s%s(%s,kds,1) , & ! Field \n" , structname , core , p->name, bdy_indicator(ibdy), ms1 ) ;
848 } else {
849 fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ;
850 }
851 } else {
852 if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; }
853 else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
854 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
855 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
856 fprintf(fp," %s%s%s%s%s(%s,kds,1,P_%s) , & ! Field \n" ,
857 structname , core , fourdname, tend_tag, bdy_indicator(ibdy), ms1, p->name ) ;
858 } else {
859 fprintf(fp," %s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" ,
860 structname , core , fourdname, tend_tag, ibdy, p->name ) ;
861 }
862 }
863 if (!strncmp(p->type->name,"real",4)) {
864 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
865 } else {
866 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
867 }
868 fprintf(fp," grid%%communicator , & ! Comm\n") ;
869 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
870 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
871 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ;
872 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
873 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
874 fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
875 /* global dimensions */
876 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
877 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
878 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
879 fprintf(fp," ierr )\n") ;
880 if ( ok_to_collect_distribute )
881 {
882 fprintf(fp,"ENDIF\n") ;
883 fprintf(fp,"CALL wrf_dm_bcast_%s ( %s%s%s ( 1, 1 , 1 , %d ) , &\n",p->type->name, structname , core , p->name, ibdy) ;
884 fprintf(fp," ((%s)-(%s)+1)*((%s)-(%s)+1)*((%s)-(%s)+1) )\n",me1,ms1,me2,ms2,me3,ms3) ;
885 }
886 #if DA_CORE==1
887 if ( !strncmp(dname, "A_", 2) ) {
888 fprintf(fp,"END IF\n") ;
889 }
890 else if ( !strncmp(dname, "G_", 2) ) {
891 fprintf(fp,"END IF\n") ;
892 }
893 #endif
894 if ( !strncmp( p->use, "dyn_", 4 ) )
895 fprintf(fp,"END IF\n" ) ;
896 }
897 else if ( sw_io == GEN_OUTPUT )
898 {
899 if ( ok_to_collect_distribute )
900 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
901 if ( !strncmp( p->use, "dyn_", 4 ) )
902 #if DA_CORE==1
903 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
904 if ( !strncmp(dname, "A_", 2) ) {
905 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
906 }
907 else if ( !strncmp(dname, "G_", 2) ) {
908 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
909 }
910 #else
911 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
912 #endif
913 fprintf(fp,"CALL wrf_ext_write_field ( &\n") ;
914 fprintf(fp," fid , & ! DataHandle \n" ) ;
915 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
916 if ( fourdname == NULL ) {
917 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
918 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
919 fprintf(fp," %s%s%s%s(%s,kds,1) , & ! Field \n" , structname , core , p->name, bdy_indicator(ibdy), ms1 ) ;
920 } else {
921 fprintf(fp," %s%s%s(1,kds,1,%d) , & ! Field \n" , structname , core , p->name, ibdy ) ;
922 }
923 } else {
924 if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag) ; }
925 else { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
926 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
927 if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
928 fprintf(fp," %s%s%s%s%s(%s,kds,1,P_%s) , & ! Field \n" ,
929 structname , core , fourdname, tend_tag, ms1, bdy_indicator(ibdy), p->name ) ;
930 } else {
931 fprintf(fp," %s%s%s%s%s(1,kds,1,%d,P_%s) , & ! Field \n" ,
932 structname , core , fourdname, tend_tag, ibdy, bdy_indicator(ibdy), p->name ) ;
933 }
934 }
935 if (!strncmp(p->type->name,"real",4)) {
936 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
937 } else {
938 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
939 }
940 fprintf(fp," grid%%communicator , & ! Comm\n") ;
941 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
942 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
943 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ;
944 fprintf(fp," dryrun , & ! flag\n" ) ;
945 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
946 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
947 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
948 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
949 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
950 fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ;
951 fprintf(fp," '%s' , & ! Units \n",p->units ) ;
952 fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
953 /* global dimensions */
954 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
955 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
956 fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
957 fprintf(fp," ierr )\n") ;
958 #if DA_CORE==1
959 if ( !strncmp(dname, "A_", 2) ) {
960 fprintf(fp,"END IF\n") ;
961 }
962 else if ( !strncmp(dname, "G_", 2) ) {
963 fprintf(fp,"END IF\n") ;
964 }
965 #endif
966 if ( !strncmp( p->use, "dyn_", 4 ) )
967 fprintf(fp,"END IF\n" ) ;
968 if ( ok_to_collect_distribute )
969 fprintf(fp,"ENDIF\n") ;
970 }
971 }
972 }
973 }
974
975 /* //////// NOT BOUNDARY ///////////////////// */
976 else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY))
977 {
978
979 /* Aug 2004
980
981 Namelist variables
982
983 The i r and h settings will be reenabled but it will work a little
984 differently than i/o of regular state variables:
985
986 1) rather than being read or written as records to the dataset, they
987 will be gotten or put as time invariant meta data; in other words, they
988 will only be written once when the dataset is created as the other
989 metadata is now. This has the benefit of reducing the amount of I/O
990 traffic on each write (I can't remember, but that may be why the
991 reading and writing of rconfig data was turned off in the first
992 place).
993
994 2) All the rconfig variables will be gotten/put as metadata to input,
995 restart, history, and boundary datasets, regardless of what the 'i',
996 'r', and 'h' settings are. Instead those settings will control the
997 behavior with respect to the input-from-namelist vs input-from-dataset
998 precedence issue that Bill raised.
999
1000 In other words, if an rconfig entry has an 'i', 'r', or 'h' in the
1001 Registry, the dataset value takes precedence over the namelist value.
1002 Otherwise, say it is missing the 'i', the reconfig variable's value
1003 still appears as metadata in the dataset but the value of the variable
1004 in the program does not change as a result of inputting the dataset.
1005
1006 */
1007
1008 if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) )
1009 {
1010 char c ;
1011 char dname[NAMELEN] ;
1012
1013 strcpy( dname, p->dname ) ;
1014 make_upper_case( dname ) ;
1015 if ( !strcmp( p->type->name , "integer" ) ) { c = 'i' ; }
1016 else if ( !strcmp( p->type->name , "real" ) ) { c = 'r' ; }
1017 else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; }
1018 else if ( !strcmp( p->type->name , "logical" ) ) { c = 'l' ; }
1019 else {
1020 fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ;
1021 }
1022 if ( sw_io == GEN_OUTPUT ) {
1023 if ( io_mask & p->io_mask ) {
1024 fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
1025 fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
1026 }
1027 } else {
1028 if ( io_mask & p->io_mask ) {
1029 fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
1030 fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ;
1031 fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ;
1032 fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
1033 }
1034 }
1035 }
1036 /* end Aug 2004 */
1037 #if 0
1038 else if ( ! (io_mask & METADATA) ) /* state vars */
1039 #else
1040 else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) ) /* state vars */
1041 #endif
1042 {
1043 if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ;
1044 else passes = 1 ;
1045
1046 for ( pass = 0 ; pass < passes ; pass++ ) /* for multi timelevel vars */
1047 {
1048 if (!strncmp( p->use, "dyn_", 4))
1049 sprintf(core,"%s_",p->use+4) ;
1050 else
1051 strcpy(core,"") ;
1052
1053 /* for multi time level variables gen read for both levels
1054 for restart, only _2 for others */
1055 if ( p->ntl > 1 ) {
1056 if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ;
1057 else sprintf(tag,"_%d",p->ntl) ;
1058 }
1059 else sprintf(tag,"") ;
1060
1061 /* construct variable name */
1062 if ( p->scalar_array_member )
1063 {
1064 strcpy(dexes,"") ;
1065 for (ii = 0; ii < p->ndims; ii++ )
1066 {
1067 switch(p->dims[ii]->coord_axis)
1068 {
1069 case(COORD_X): strcat(dexes,"ims,") ; break ;
1070 case(COORD_Y): strcat(dexes,"jms,") ; break ;
1071 case(COORD_Z): strcat(dexes,"kms,") ; break ;
1072 default : break ;
1073 }
1074 }
1075 sprintf(vname,"%s%s%s(%sP_%s)",core,p->use,tag,dexes,p->name) ;
1076 sprintf(vname_2,"%s%s%s(%sP_%s)",core,p->use,"_2",":,:,:,",p->name) ;
1077 sprintf(vname_1,"%s%s%s(%sP_%s)",core,p->use,"_1",":,:,:,",p->name) ;
1078 sprintf(vname_x,"%s%s%s(%sP_%s)",core,p->use,tag,":,:,:,",p->name) ;
1079 }
1080 else
1081 {
1082 sprintf(vname,"%s%s%s",core,p->name,tag) ;
1083 sprintf(vname_x,"%s%s%s",core,p->name,tag) ;
1084 sprintf(vname_1,"%s%s%s",core,p->name,"_1") ;
1085 sprintf(vname_2,"%s%s%s",core,p->name,"_2") ;
1086 }
1087
1088
1089 /* construct data name -- maybe same as vname if dname not spec'd */
1090 if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; }
1091 else { strcpy(dname_tmp,p->dname) ; }
1092 make_upper_case(dname_tmp) ;
1093
1094 /*
1095 July 2004
1096
1097 New code to generate error if input or output for two state variables would be generated with the same dataname
1098
1099 example okay:
1100 dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB
1101 dyn_em soiltb "SOILTB" -> dyn_em_tg,SOILTB
1102 example wrong:
1103 dyn_nmm tg "SOILTB" -> dyn_nmm_tg,SOILTB
1104 misc soiltb "SOILTB" -> gen_soiltb,SOILTB
1105 example wrong:
1106 misc tg "SOILTB" -> gen_tg,SOILTB
1107 misc soiltb "SOILTB" -> gen_soiltb,SOILTB
1108
1109 */
1110 if ( pass == 0 )
1111 {
1112 char dname_symbol[128] ;
1113 sym_nodeptr sym_node ;
1114
1115 sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ;
1116 /* check and see if it is in the symbol table already */
1117
1118 if ((sym_node = sym_get( dname_symbol )) == NULL ) {
1119 /* add it */
1120 sym_node = sym_add ( dname_symbol ) ;
1121 strcpy( sym_node->internal_name , p->name ) ;
1122 strcpy( sym_node->core_name , core ) ;
1123 } else {
1124 /* it's there already, check and make sure we don't have an error condition */
1125 if ( (strlen(core) > 0 && strlen( sym_node->core_name ) > 0 && !strcmp( core, sym_node->core_name ))
1126 || strlen(core) == 0
1127 || strlen( sym_node->core_name ) == 0 )
1128 {
1129 char this_core[64] , sym_core[64] ;
1130 strcpy(this_core,"(generic)") ;
1131 if ( strlen(core) > 0 ) sprintf(this_core,"(%s)",core) ;
1132 strcpy(sym_core,"(generic)") ;
1133 if ( strlen(sym_node->core_name) > 0 ) sprintf(this_core,"(%s)",sym_node->core_name) ;
1134 fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s %s and %s %s\n",
1135 dname_tmp,p->name,this_core,sym_node->internal_name,sym_core ) ;
1136 }
1137 }
1138 }
1139 /* end July 2004 */
1140
1141 if ( io_mask & RESTART && p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ;
1142 else strcpy(dname,dname_tmp) ;
1143
1144 set_mem_order( p, memord , NAMELEN) ;
1145
1146 /* kludge for WRF 3DVAR I/O with MM5 analysis kernel */
1147 if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ;
1148 if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ;
1149
1150 if ( strlen(dname) < 1 ) {
1151 fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ;
1152 }
1153 if ( p->io_mask & io_mask && sw_io == GEN_INPUT )
1154 {
1155 if ( !strncmp( p->use, "dyn_", 4 ) )
1156 #if DA_CORE==1
1157 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
1158 if ( !strncmp(dname, "A_", 2) ) {
1159 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1160 }
1161 else if ( !strncmp(dname, "G_", 2) ) {
1162 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1163 }
1164 #else
1165 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
1166 #endif
1167 if ( p->scalar_array_member )
1168 fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1169 if ( ok_to_collect_distribute )
1170 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1171
1172 strcpy(indices,"") ;
1173 sprintf(post,")") ;
1174 if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */
1175 {
1176 sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ;
1177 }
1178
1179 fprintf(fp,"CALL wrf_ext_read_field ( &\n") ;
1180 fprintf(fp," fid , & ! DataHandle \n" ) ;
1181 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
1182 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
1183 if ( p->ndims >= 2 && ok_to_collect_distribute )
1184 fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ;
1185 else
1186 fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices) ;
1187
1188 if (!strncmp(p->type->name,"real",4)) {
1189 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
1190 } else {
1191 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
1192 }
1193
1194 fprintf(fp," grid%%communicator , & ! Comm\n") ;
1195 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
1196 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
1197 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
1198 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
1199 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
1200 fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1201 /* global dimensions */
1202 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1203 fprintf(fp," & \n") ;
1204
1205 /* the first two cases here have to do with if we're running on multiple distributed
1206 memory processors and the i/o api layer can't handle decomposed data. So code is
1207 generated to read the data on processor zero into a globally sized buffer. In this
1208 case, then the domain, memory, and patch dimensions for the globally sized buffer
1209 are all just the domain dimensions. Two D arrays are handled separately
1210 from three-d arrays because in threeD arrays the middle index is K. In the last
1211 case, where the code is either calling a version of the API that supports parallelism
1212 or we aren't running in DM-parallel, the field itself and not a global buffer are
1213 passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1214
1215 if ( p->ndims == 3 && ok_to_collect_distribute )
1216 {
1217 /* mem dimensions are actually domain dimensions */
1218 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1219 fprintf(fp," & \n") ;
1220 /* patch dimensions are actually domain dimensions */
1221 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim [i][0], ddim [i][1]) ; }
1222 fprintf(fp," & \n") ;
1223 }
1224 else if ( p->ndims == 2 && ok_to_collect_distribute )
1225 {
1226 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1227 {
1228 /* mem dimensions are actually domain dimensions */
1229 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1230 ddim_no[yi][0],ddim_no[yi][1] ) ;
1231 /* patch dimensions are actually domain dimensions */
1232 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim [xi][0],ddim [xi][1],
1233 ddim [yi][0],ddim [yi][1] ) ;
1234 }
1235 }
1236 else
1237 {
1238 /* mem dimensions */
1239 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1240 fprintf(fp," & \n") ;
1241 /* patch dimensions */
1242 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1243 fprintf(fp," & \n") ;
1244 }
1245 fprintf(fp," ierr )\n") ;
1246
1247 if ( ok_to_collect_distribute )
1248 fprintf(fp,"END IF\n" ) ;
1249
1250 /* In case we have read into a global buffer, generate code to distribute the data just read in */
1251 if ( p->ndims == 3 && ok_to_collect_distribute )
1252 {
1253 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0)
1254 {
1255 fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1256 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1257 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1258 ddim_no[yi][0],ddim_no[yi][1],
1259 ddim_no[zi][0],ddim_no[zi][1]) ;
1260 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1261 mdim_no[yi][0],mdim_no[yi][1],
1262 mdim_no[zi][0],mdim_no[zi][1]) ;
1263 fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1],
1264 pdim_no[yi][0],pdim_no[yi][1],
1265 pdim_no[zi][0],pdim_no[zi][1]) ;
1266 }
1267 }
1268 else if ( p->ndims == 2 && ok_to_collect_distribute )
1269 {
1270 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1271 {
1272 fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1273 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1274 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1275 ddim_no[yi][0],ddim_no[yi][1] ) ;
1276 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1277 mdim_no[yi][0],mdim_no[yi][1] ) ;
1278 fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1],
1279 pdim_no[yi][0],pdim_no[yi][1] ) ;
1280 }
1281 else
1282 {
1283 fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1284 }
1285 }
1286 else if ( !strcmp(memord,"Z") && ok_to_collect_distribute )
1287 {
1288 fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ;
1289 }
1290 else if ( !strcmp(memord,"0") && ok_to_collect_distribute )
1291 {
1292 fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ;
1293
1294 }
1295 else if ( ok_to_collect_distribute )
1296 {
1297 fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ;
1298 }
1299
1300 if ( io_mask & INPUT && p->ntl > 1 ) {
1301 /* copy time level two into time level one */
1302 if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ;
1303 if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ;
1304 }
1305
1306 if ( p->scalar_array_member )
1307 {
1308 fprintf(fp,"END IF\n" ) ;
1309 }
1310
1311 #if DA_CORE==1
1312 if ( !strncmp(dname, "A_", 2) ) {
1313 fprintf(fp,"END IF\n") ;
1314 }
1315 else if ( !strncmp(dname, "G_", 2) ) {
1316 fprintf(fp,"END IF\n") ;
1317 }
1318 #endif
1319 if ( !strncmp( p->use, "dyn_", 4 ) )
1320 fprintf(fp,"END IF\n" ) ;
1321 }
1322 else if ( sw_io == GEN_OUTPUT )
1323 {
1324 if ( !strncmp( p->use, "dyn_", 4 ) )
1325 #if DA_CORE==1
1326 fprintf(fp,"IF ( mod(grid%%dyn_opt,100) .EQ. %s ) THEN\n",p->use) ;
1327 if ( !strncmp(dname, "A_", 2) ) {
1328 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1329 }
1330 else if ( !strncmp(dname, "G_", 2) ) {
1331 fprintf(fp,"IF ( grid%%dyn_opt == DYN_EM_TL .or. grid%%dyn_opt == DYN_EM_AD ) THEN\n") ;
1332 }
1333 #else
1334 fprintf(fp,"IF ( grid%%dyn_opt .EQ. %s ) THEN\n",p->use) ;
1335 #endif
1336 if ( p->scalar_array_member )
1337 fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1338
1339 /* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data */
1340
1341 if ( p->ndims == 3 && ok_to_collect_distribute )
1342 {
1343 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0&&(zi=get_index_for_coord(p,COORD_Z))>=0)
1344 {
1345 fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1346 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1347 /* fprintf(fp, "ids , ide , jds , jde , kds , kde , &\n") ; */
1348 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1349 ddim_no[yi][0],ddim_no[yi][1],
1350 ddim_no[zi][0],ddim_no[zi][1]) ;
1351 fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1352 mdim_no[yi][0],mdim_no[yi][1],
1353 mdim_no[zi][0],mdim_no[zi][1]) ;
1354 fprintf(fp, "%s, %s, %s, %s, %s, %s )\n",pdim_no[xi][0],pdim_no[xi][1],
1355 pdim_no[yi][0],pdim_no[yi][1],
1356 pdim_no[zi][0],pdim_no[zi][1]) ;
1357 }
1358 }
1359 else if ( p->ndims == 2 && ok_to_collect_distribute )
1360 {
1361 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1362 {
1363 fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1364 fprintf(fp," grid%%domdesc, %d, &\n",p->ndims) ;
1365 /* fprintf(fp, "ids , ide , jds , jde , 1 , 1 , &\n") ; */
1366 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1367 ddim_no[yi][0],ddim_no[yi][1] ) ;
1368 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1369 mdim_no[yi][0],mdim_no[yi][1] ) ;
1370 fprintf(fp, "%s, %s, %s, %s, 1 , 1 )\n",pdim_no[xi][0],pdim_no[xi][1],
1371 pdim_no[yi][0],pdim_no[yi][1] ) ;
1372 }
1373 else
1374 {
1375 fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1376 }
1377 }
1378
1379 for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
1380 for ( i = 0 ; i < 3 ; i++ )
1381 {
1382 if (( dimnode = p->dims[i]) != NULL )
1383 {
1384 switch ( dimnode->coord_axis )
1385 {
1386 case (COORD_X) :
1387 if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
1388 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
1389 else if ( p->dims[i]->subgrid )
1390 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1391 else
1392 { strcpy( dimname[i], dimnode->dim_data_name) ; }
1393 break ;
1394 case (COORD_Y) :
1395 if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
1396 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
1397 else if ( p->dims[i]->subgrid )
1398 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1399 else
1400 { strcpy( dimname[i], dimnode->dim_data_name) ; }
1401 break ;
1402 case (COORD_Z) :
1403 if ( p->stag_z )
1404 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
1405 else if ( p->dims[i]->subgrid )
1406 { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1407 else
1408 { strcpy( dimname[i], dimnode->dim_data_name) ; }
1409 break ;
1410 }
1411 }
1412 }
1413
1414 if ( ok_to_collect_distribute )
1415 fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1416
1417 strcpy(indices,"") ;
1418 sprintf(post,")") ;
1419 if ( sw_io_deref_kludge && !(p->scalar_array_member) ) /* these aready have */
1420 {
1421 sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ;
1422 }
1423
1424 if ( !(p->scalar_array_member) ) {
1425 fprintf(fp,"CALL wrf_ext_write_field ( &\n") ;
1426 fprintf(fp," fid , & ! DataHandle \n" ) ;
1427 fprintf(fp," current_date(1:19) , & ! DateStr \n" ) ;
1428 fprintf(fp," '%s' , & ! Data Name \n", dname ) ;
1429 if ( p->ndims >= 2 && ok_to_collect_distribute )
1430 fprintf(fp," globbuf_%s , & ! Field \n" , p->type->name ) ;
1431 else
1432 fprintf(fp," %s%s%s , & ! Field \n" , structname , vname , indices ) ;
1433 if (!strncmp(p->type->name,"real",4)) {
1434 fprintf(fp," WRF_FLOAT , & ! FieldType \n") ;
1435 } else {
1436 fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ;
1437 }
1438 fprintf(fp," grid%%communicator , & ! Comm\n") ;
1439 fprintf(fp," grid%%iocommunicator , & ! Comm\n") ;
1440 fprintf(fp," grid%%domdesc , & ! Comm\n") ;
1441 fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ;
1442 fprintf(fp," dryrun , & ! flag\n" ) ;
1443 fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ;
1444 fprintf(fp," '%s' , & ! Stagger\n",stagstr ) ;
1445 fprintf(fp," '%s' , & ! Dimname 1 \n",dimname[0] ) ;
1446 fprintf(fp," '%s' , & ! Dimname 2 \n",dimname[1] ) ;
1447 fprintf(fp," '%s' , & ! Dimname 3 \n",dimname[2] ) ;
1448 fprintf(fp," '%s' , & ! Desc \n",p->descrip ) ;
1449 fprintf(fp," '%s' , & ! Units \n",p->units ) ;
1450 fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1451 /* global dimensions */
1452 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1453 fprintf(fp," & \n") ;
1454
1455 /* the first two cases here have to do with if we're running on multiple distributed
1456 memory processors and the i/o api layer can't handle decomposed data. So code is
1457 generated to read the data on processor zero into a globally sized buffer. In this
1458 case, then the domain, memory, and patch dimensions for the globally sized buffer
1459 are all just the domain domain dimensions. Two D arrays are handled separately
1460 from three-d arrays because in threeD arrays the middle index is K. In the last
1461 case, where the code is either calling a version of the API that supports parallelism
1462 or we aren't running in DM-parallel, the field itself and not a global buffer are
1463 passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1464
1465 if ( p->ndims == 3 && ok_to_collect_distribute )
1466 {
1467 /* mem dimensions are actually domain dimensions */
1468 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1469 fprintf(fp," & \n") ;
1470 /* patch dimensions are actually domain dimensions */
1471 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1472 fprintf(fp," & \n") ;
1473 }
1474 else if ( p->ndims == 2 && ok_to_collect_distribute )
1475 {
1476 if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1477 {
1478 /* mem dimensions are actually domain dimensions */
1479 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1480 ddim_no[yi][0],ddim_no[yi][1] ) ;
1481 /* patch dimensions are actually domain dimensions */
1482 fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1],
1483 ddim[yi][0],ddim[yi][1] ) ;
1484 }
1485 }
1486 else
1487 {
1488 /* mem dimensions */
1489 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1490 fprintf(fp," & \n") ;
1491 /* patch dimensions */
1492 for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1493 fprintf(fp," & \n") ;
1494 }
1495 fprintf(fp," ierr )\n") ;
1496
1497 if ( ok_to_collect_distribute )
1498 fprintf(fp,"END IF\n" ) ;
1499
1500 /*
1501 if ( p->scalar_array_member )
1502 fprintf(fp,"END IF\n" ) ;
1503 */
1504 #if DA_CORE==1
1505 if ( !strncmp(dname, "A_", 2) ) {
1506 fprintf(fp,"END IF\n") ;
1507 }
1508 else if ( !strncmp(dname, "G_", 2) ) {
1509 fprintf(fp,"END IF\n") ;
1510 }
1511 #endif
1512 if ( !strncmp( p->use, "dyn_", 4 ) )
1513 fprintf(fp,"END IF\n" ) ;
1514
1515 }
1516 }
1517 }
1518 }
1519 }
1520 }
1521 if ( p->type->type_type == DERIVED )
1522 {
1523 sprintf(x,"%s%s%%",structname,p->name ) ;
1524 gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ;
1525 }
1526
1527 }
1528 }
1529 return(0) ;
1530 }
1531