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