source: trunk/WRF.COMMON/WRFV3/tools/gen_wrf_io.c @ 3608

Last change on this file since 3608 was 2759, checked in by aslmd, 3 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 64.2 KB
RevLine 
[2759]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
11static 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
24int
25gen_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
230static int
231set_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
345int
346set_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  */
353int
354set_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
359int
360gen_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 stagstr[NAMELEN] ;
375  char * tend_tag ;
376
377  char post[NAMELEN] ;
378  char indices[NAMELEN] ;
379
380  int pass, passes, stagx, stagy, stagz ;
381  int xi, yi, zi ;
382  node_t * dimnode ;
383  int ok_to_collect_distribute ;
384
385/* set a flag according to what the stream is, if we're running on dm processors, if the
386   io layer cannot handle distributed data, and if we're selectively turning off the
387   collect/distribute message passing so that history and restart I/O is to separate files
388   but input and boundary I/O is unaffected */
389
390  ok_to_collect_distribute = !sw_distrib_io_layer && 
391                              sw_dm_parallel && 
392                             !(sw_dm_serial_in_only && ((io_mask&HISTORY)  ||
393                                                        (io_mask&AUXHIST1) ||
394                                                        (io_mask&AUXHIST2) ||
395                                                        (io_mask&AUXHIST3) ||
396                                                        (io_mask&AUXHIST4) ||
397                                                        (io_mask&AUXHIST5) ||
398                                                        (io_mask&AUXHIST6) ||
399                                                        (io_mask&AUXHIST7) ||
400                                                        (io_mask&AUXHIST8) ||
401                                                        (io_mask&AUXHIST9) ||
402                                                        (io_mask&AUXHIST10) ||
403                                                        (io_mask&AUXHIST11) ||
404                                                        (io_mask&RESTART))) ;
405
406  if ( node == NULL ) return(1) ;
407  if ( structname == NULL ) return(1) ;
408  if ( fp == NULL ) return(1) ;
409
410  for ( p = node ; p != NULL ; p = p->next )
411  {
412
413    if ( p->ndims > 3 ) continue ; /* short circuit anything with more than 3 dims, (not counting 4d arrays) */
414
415    if ( p->node_kind & I1 ) continue ;  /* short circuit anything that's not a state var */
416
417    set_dim_strs( p, ddim, mdim, pdim , "", 0 ) ;           /* dimensions with staggering */
418    set_dim_strs( p, ddim_no, mdim_no, pdim_no , "", 1 ) ;  /* dimensions ignoring staggering */
419
420    strcpy(stagstr, "") ;
421    if ( p->stag_x ) strcat(stagstr, "X") ;
422    if ( p->stag_y ) strcat(stagstr, "Y") ;
423    if ( p->stag_z ) strcat(stagstr, "Z") ;
424
425    if ( !strcmp(p->name,"-") ) continue ;
426
427    if ( p->node_kind & FOURD )
428    {
429      node_t * nd , *pp ;
430      char p1[NAMELEN], sv[NAMELEN], tl[25] ;
431
432      set_dim_strs( p->members, ddim, mdim, pdim , "", 0 ) ;           /* dimensions with staggering */
433      set_dim_strs( p->members, ddim_no, mdim_no, pdim_no , "", 1 ) ;  /* dimensions ignoring staggering */
434
435      if ( ! ( io_mask & BOUNDARY ) )
436      {
437        set_mem_order( p->members, memord , NAMELEN) ;
438fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
439fprintf(fp,"  IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
440fprintf(fp,"    CALL wrf_ext_%s_field (  &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
441fprintf(fp,"          fid                             , &  ! DataHandle\n") ;
442fprintf(fp,"          current_date(1:19)              , &  ! DateStr\n") ; 
443fprintf(fp,"          TRIM(%s_dname_table( grid%%id, itrace )), & !data name\n",p->name) ;
444        strcpy( tl, "" ) ;
445        if ( p->members->ntl > 1 && p->members->ntl <= 3 ) sprintf( tl, "_%d",p->members->ntl ) ;
446        if ( ok_to_collect_distribute ) {
447fprintf(fp,"                       globbuf_%s               , &  ! Field \n",p->members->type->name ) ;
448        } else {
449           if        ( !strcmp(memord,"XYZ") ) {
450fprintf(fp,"          grid%%%s%s(ims,jms,kms,itrace)  , &  ! Field\n",p->name,tl) ;
451           } else if ( !strcmp(memord,"YXZ") ) {
452fprintf(fp,"          grid%%%s%s(jms,ims,kms,itrace)  , &  ! Field\n",p->name,tl) ;
453           } else if ( !strcmp(memord,"XZY") ) {
454fprintf(fp,"          grid%%%s%s(ims,kms,jms,itrace)  , &  ! Field\n",p->name,tl) ;
455           } else if ( !strcmp(memord,"YZX") ) {
456fprintf(fp,"          grid%%%s%s(jms,kms,ims,itrace)  , &  ! Field\n",p->name,tl) ;
457           } else if ( !strcmp(memord,"ZXY") ) {
458fprintf(fp,"          grid%%%s%s(kms,ims,jms,itrace)  , &  ! Field\n",p->name,tl) ;
459           } else if ( !strcmp(memord,"ZYX") ) {
460fprintf(fp,"          grid%%%s%s(kms,jms,ims,itrace)  , &  ! Field\n",p->name,tl) ;
461           }
462        }
463        if (!strncmp(p->members->type->name,"real",4)) {
464          fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
465        } else {
466          fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->members->type->name ) ;
467        }
468fprintf(fp,"          grid%%communicator  , &  ! Comm\n") ;
469fprintf(fp,"          grid%%iocommunicator  , &  ! Comm\n") ;
470fprintf(fp,"          grid%%domdesc       , &  ! Comm\n") ;
471fprintf(fp,"          grid%%bdy_mask       , &  ! bdy_mask\n") ;
472        if ( sw_io == GEN_OUTPUT ) {
473fprintf(fp,"          dryrun             , &  ! flag\n") ;
474        }
475/* fprintf(stderr,"name %s memord %s\n",p->name,memord) ; */
476fprintf(fp,"          '%s'               , &  ! MemoryOrder\n",memord) ;
477        strcpy(stagstr, "") ;
478        if ( p->members->stag_x ) strcat(stagstr, "X") ;
479        if ( p->members->stag_y ) strcat(stagstr, "Y") ;
480        if ( p->members->stag_z ) strcat(stagstr, "Z") ;
481fprintf(fp,"          '%s'                , &  ! Stagger\n",stagstr) ;
482        if ( sw_io == GEN_OUTPUT ) {
483          for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
484          for ( i = 0 ; i < 3 ; i++ )
485          {
486            if (( dimnode = p->members->dims[i]) != NULL )
487            {
488              switch ( dimnode->coord_axis )
489              {
490              case (COORD_X) :
491                if ( ( ! sw_3dvar_iry_kludge && p->members->stag_x ) || ( sw_3dvar_iry_kludge && p->members->stag_y ) )
492                 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
493                else
494                 { strcpy( dimname[i], dimnode->dim_data_name) ; }
495                break ;
496              case (COORD_Y) :
497                if ( ( ! sw_3dvar_iry_kludge && p->members->stag_y ) || ( sw_3dvar_iry_kludge && p->members->stag_x ) )
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_Z) :
503                if ( p->members->stag_z )
504                 { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; }
505                else
506                 { strcpy( dimname[i], dimnode->dim_data_name) ; }
507                break ;
508              }
509            }
510          }
511fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
512fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
513fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
514fprintf(fp,"          %s_desc_table( grid%%id, itrace  ), & ! Desc\n",p->name) ;
515fprintf(fp,"          %s_units_table( grid%%id, itrace  ), & ! Units\n",p->name) ;
516        }
517fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name, memord ) ;
518        /* global dimensions */
519        for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
520        fprintf(fp," & \n") ;
521        /* mem    dimensions */
522        for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
523        fprintf(fp," & \n") ;
524        /* patch  dimensions */
525        for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
526        fprintf(fp," & \n") ;
527fprintf(fp,"                         ierr )\n" ) ;
528fprintf(fp, "  ENDIF\n" ) ;
529fprintf(fp, "ENDDO\n") ;
530      } 
531/* BOUNDARY FOR 4-D TRACER */
532      else if ( io_mask & BOUNDARY )
533      {
534        int ibdy ;
535        int idx ;
536        node_t *fourd_bound_array ;
537        char *bdytag, *xdomainend, *ydomainend, *zdomainend, bdytag2[10],fourd_bnd[NAMELEN] ;
538        char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
539
540/* check for the existence of a fourd boundary array */
541        sprintf(fourd_bnd,"%s_b",p->name) ;
542        if (( fourd_bound_array = get_entry( fourd_bnd  ,Domain.fields)) != NULL ) {
543
544          for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
545          strcpy( dimname[2] , "bdy_width" ) ;
546          ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
547          ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
548          ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
549          if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
550           { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; }
551             else             { strcpy(  dimname[1], dimnode->dim_data_name) ; }
552             if ( p->stag_z ) { zdomainend = "kde" ; }
553             else             { zdomainend = "(kde-1)" ; }
554             ds2 = "kds" ; de2 = zdomainend ;
555             ms2 = "kds" ; me2 = "kde" ;   /* 20020924 */
556             ps2 = "kds" ; pe2 = zdomainend ;
557           }
558          else
559           {
560             fprintf(stderr,"REGISTRY WARNING: 4D ARRAYS MUST HAVE VERT DIMENSION\n") ;
561           }
562          for ( pass = 0 ; pass < 2 ; pass++ ) {
563fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR , num_%s\n",p->name ) ;
564fprintf(fp,"  IF (BTEST(%s_stream_table(grid%%id, itrace ) , switch )) THEN\n",p->name) ;
565          for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
566          {
567            if        ( pass == 0 && ibdy == 1 ) { bdytag = "_BXS" ;      /* west bdy   */
568            } else if ( pass == 0 && ibdy == 2 ) { bdytag = "_BXE" ;      /* east bdy   */
569            } else if ( pass == 0 && ibdy == 3 ) { bdytag = "_BYS" ;      /* south bdy   */
570            } else if ( pass == 0 && ibdy == 4 ) { bdytag = "_BYE" ;      /* north bdy   */
571            } else if ( pass == 1 && ibdy == 1 ) { bdytag = "_BTXS" ;      /* west bdy   */
572            } else if ( pass == 1 && ibdy == 2 ) { bdytag = "_BTXE" ;      /* east bdy   */
573            } else if ( pass == 1 && ibdy == 3 ) { bdytag = "_BTYS" ;      /* south bdy   */
574            } else if ( pass == 1 && ibdy == 4 ) { bdytag = "_BTYE" ;      /* north bdy   */
575            }
576            if ( ibdy == 1 || ibdy == 2 ) {
577              if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
578              {
579                idx = get_index_for_coord( p , COORD_Y  ) ;
580                if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
581                ds1 = "1" ; de1 = ydomainend ;
582                ms1 = "1" ; me1 = "MAX( ide , jde )" ;
583                if ( sw_new_bdys ) {  /* 20070207 */
584                  if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; }
585                  if        ( sw_io == GEN_INPUT ) {
586                    ps1 = "MAX(jms,jds)" ;
587                    sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ;
588                  } else if ( sw_io == GEN_OUTPUT ) {
589                    ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
590                  }
591                } else {
592                  if        ( sw_io == GEN_INPUT ) {
593                    ps1 = "1" ; pe1 = ydomainend ;
594                  } else if ( sw_io == GEN_OUTPUT ) {
595                    ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
596                  }
597                }
598                if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
599                else                   { strcpy( dimname[0], dimnode->dim_data_name) ; }
600              }
601            }
602            if ( ibdy == 3 || ibdy == 4 ) {
603              if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
604              {
605                idx = get_index_for_coord( p , COORD_X  ) ;
606                if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
607                ds1 = "1" ; de1 = xdomainend ;
608                ms1 = "1" ; me1 = "MAX( ide , jde )" ;
609                if ( sw_new_bdys ) {  /* 20070207 */
610                  if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; }
611                  if        ( sw_io == GEN_INPUT ) {
612                    ps1 = "MAX(ims,ids)" ;
613                    sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ;
614                  } else if ( sw_io == GEN_OUTPUT ) {
615                    ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
616                  }
617                } else {
618                  if        ( sw_io == GEN_INPUT ) {
619                    ps1 = "1" ; pe1 = xdomainend ;
620                  } else if ( sw_io == GEN_OUTPUT ) {
621                    ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
622                  }
623                }
624                if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
625                else             { strcpy( dimname[0], dimnode->dim_data_name) ; }
626              }
627            }
628            if      ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag+2+pass ) ;
629            else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag+2+pass ) ;
630            else                      sprintf(memord,"0") ;
631fprintf(fp,"    CALL wrf_ext_%s_field (  &\n", (sw_io == GEN_INPUT)?"read":"write" ) ;
632fprintf(fp,"          fid                             , &  ! DataHandle\n") ;
633fprintf(fp,"          current_date(1:19)              , &  ! DateStr\n") ; 
634fprintf(fp,"          TRIM(%s_dname_table( grid%%id, itrace )) // '%s', & !data name\n",p->name,bdytag) ;
635            if ( ok_to_collect_distribute ) {
636fprintf(fp,"                       globbuf_%s               , &  ! Field \n",p->members->type->name ) ;
637            } else {
638              strcpy(bdytag2,"") ;
639              strncat(bdytag2,bdytag, pass+2) ;
640if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
641  fprintf(fp,"          grid%%%s%s(%s,kds,1,itrace)  , &  ! Field\n",p->name,bdytag, ms1) ;
642} else {
643  fprintf(fp,"          grid%%%s%s(1,kds,1,%d,itrace)  , &  ! Field\n",p->name,bdytag2, ibdy) ;
644}
645            }
646            if (!strncmp(p->members->type->name,"real",4)) {
647              fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
648            } else {
649              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->members->type->name ) ;
650            }
651fprintf(fp,"          grid%%communicator  , &  ! Comm\n") ;
652fprintf(fp,"          grid%%iocommunicator  , &  ! Comm\n") ;
653fprintf(fp,"          grid%%domdesc       , &  ! Comm\n") ;
654fprintf(fp,"          grid%%bdy_mask       , &  ! bdy_mask\n") ;
655            if ( sw_io == GEN_OUTPUT ) {
656fprintf(fp,"          dryrun             , &  ! flag\n") ;
657            }
658fprintf(fp,"          '%s'               , &  ! MemoryOrder\n",memord) ;
659            strcpy(stagstr, "") ;
660            if ( p->members->stag_x ) strcat(stagstr, "X") ;
661            if ( p->members->stag_y ) strcat(stagstr, "Y") ;
662            if ( p->members->stag_z ) strcat(stagstr, "Z") ;
663fprintf(fp,"          '%s'                , &  ! Stagger\n",stagstr) ;
664            if ( sw_io == GEN_OUTPUT ) {
665fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
666fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
667fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
668fprintf(fp,"          %s_desc_table( grid%%id, itrace  ), & ! Desc\n",p->name) ;
669fprintf(fp,"          %s_units_table( grid%%id, itrace  ), & ! Units\n",p->name) ;
670            }
671fprintf(fp,"'%s ext_write_field '//TRIM(%s_dname_table( grid%%id, itrace ))//' memorder %s' , & ! Debug message\n", fname, p->name,memord ) ;
672fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
673fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
674fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
675fprintf(fp,"                         ierr )\n" ) ;
676          }
677fprintf(fp, "  ENDIF\n" ) ;
678fprintf(fp, "ENDDO\n") ;
679        }
680      }
681      } /* if fourd bound array associated with this tracer */
682    }
683    else if ( p->type != NULL )
684    {
685
686    if ( p->type->type == SIMPLE )
687    {
688
689/* ////////  BOUNDARY ///////////////////// */
690
691      if (  p->io_mask & BOUNDARY && (io_mask & BOUNDARY) && !( io_mask & METADATA ) 
692         && strcmp( p->use, "_4d_bdy_array_" ) || ( io_mask & BOUNDARY && fourdname ) )
693      {
694        int ibdy ;
695        int idx ;
696        char *bdytag, *xdomainend, *ydomainend, *zdomainend ;
697        char *ds1,*de1,*ds2,*de2,*ds3,*de3,*ms1,*me1,*ms2,*me2,*ms3,*me3,*ps1,*pe1,*ps2,*pe2,*ps3,*pe3 ;
698        char t1[64], t2[64] ;
699
700        for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
701        strcpy( dimname[2] , "bdy_width" ) ;
702        ds3 = "1" ; de3 = "config_flags%spec_bdy_width" ;
703        ms3 = "1" ; me3 = "config_flags%spec_bdy_width" ;
704        ps3 = "1" ; pe3 = "config_flags%spec_bdy_width" ;
705
706        if (( dimnode = get_dimnode_for_coord( p , COORD_Z )) != NULL )
707         { if ( p->stag_z ) { sprintf( dimname[1] ,"%s_stag", dimnode->dim_data_name) ; } 
708           else             { strcpy(  dimname[1], dimnode->dim_data_name) ; }
709           if ( p->stag_z ) { zdomainend = "kde" ; } 
710           else             { zdomainend = "(kde-1)" ; }
711           ds2 = "kds" ; de2 = zdomainend ;
712           ms2 = "kds" ; me2 = "kde" ;   /* 20020924 */
713           ps2 = "kds" ; pe2 = zdomainend ;
714         }
715        else
716         { strcpy(dimname[1],dimname[2]) ;
717           strcpy(dimname[2],"one_element") ; 
718           ds2 = ds3 ; de2 = de3 ;
719           ms2 = ms3 ; me2 = me3 ;
720           ps2 = ps3 ; pe2 = pe3 ;
721           ds3 = "1" ; de3 = "1" ;
722           ms3 = "1" ; me3 = "1" ;
723           ps3 = "1" ; pe3 = "1" ;
724         }
725
726        if ( strlen(p->dname) < 1 ) {
727          fprintf(stderr,"gen_wrf_io.c: Registry WARNING: no data name for %s \n",p->name) ;
728        }
729
730        for ( ibdy = 1 ; ibdy <= 4 ; ibdy++ )
731        {
732          if        ( ibdy == 1 ) { bdytag = "XS" ;      /* west bdy   */
733          } else if ( ibdy == 2 ) { bdytag = "XE" ;      /* east bdy   */
734          } else if ( ibdy == 3 ) { bdytag = "YS" ;      /* south bdy   */
735          } else if ( ibdy == 4 ) { bdytag = "YE" ;      /* north bdy   */
736          }
737          if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s",p->name,bdytag)  ; }
738          else                                                { sprintf(dname,"%s%s",p->dname,bdytag) ; }
739
740          make_upper_case(dname) ;
741
742          if ( ibdy == 1 || ibdy == 2 ) { 
743            if (( dimnode = get_dimnode_for_coord( p , COORD_Y )) != NULL )
744            {
745              idx = get_index_for_coord( p , COORD_Y  ) ;
746              if ( p->stag_y ) { ydomainend = "jde" ; } else { ydomainend = "(jde-1)" ; }
747              ds1 = "1" ; de1 = ydomainend ;
748              ms1 = "1" ; me1 = "MAX( ide , jde )" ;
749              if ( sw_new_bdys ) {  /* 20070207 */
750                if ( ! sw_new_with_old_bdys ) { ms1 = "jms" ; me1 = "jme" ; }
751                if        ( sw_io == GEN_INPUT ) {
752                  ps1 = "MAX(jms,jds)" ;
753                  sprintf(t2,"MIN(jme,%s)",ydomainend) ; pe1 = t2 ;
754                } else if ( sw_io == GEN_OUTPUT ) {
755                  ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
756                }
757              } else {
758                if        ( sw_io == GEN_INPUT ) {
759                  ps1 = "1" ; pe1 = ydomainend ;
760                } else if ( sw_io == GEN_OUTPUT ) {
761                  ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
762                }
763              }
764              if ( p->stag_y ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
765              else                   { strcpy( dimname[0], dimnode->dim_data_name) ; }
766            }
767          }
768          if ( ibdy == 3 || ibdy == 4 ) {
769            if (( dimnode = get_dimnode_for_coord( p , COORD_X )) != NULL )
770            {
771              idx = get_index_for_coord( p , COORD_X  ) ;
772              if ( p->stag_x ) { xdomainend = "ide" ; } else { xdomainend = "(ide-1)" ; }
773              ds1 = "1" ; de1 = xdomainend ;
774              ms1 = "1" ; me1 = "MAX( ide , jde )" ;
775              if ( sw_new_bdys ) {  /* 20070207 */
776                if ( ! sw_new_with_old_bdys ) { ms1 = "ims" ; me1 = "ime" ; }
777                if        ( sw_io == GEN_INPUT ) {
778                  ps1 = "MAX(ims,ids)" ;
779                  sprintf(t2,"MIN(ime,%s)",xdomainend) ; pe1 = t2 ;
780                } else if ( sw_io == GEN_OUTPUT ) {
781                  ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
782                }
783              } else {
784                ms1 = "1" ; me1 = "MAX( ide , jde )" ;
785                if        ( sw_io == GEN_INPUT ) {
786                  ps1 = "1" ; pe1 = xdomainend ;
787                } else if ( sw_io == GEN_OUTPUT ) {
788                  ps1 = pdim[idx][0] ; pe1 = pdim[idx][1] ;
789                }
790              }
791              if ( p->stag_x ) { sprintf( dimname[0] ,"%s_stag", dimnode->dim_data_name) ; }
792              else             { strcpy( dimname[0], dimnode->dim_data_name) ; }
793            }
794          }
795          if      ( p->ndims == 3 ) sprintf(memord,"%sZ",bdytag ) ;
796          else if ( p->ndims == 2 ) sprintf(memord,"%s",bdytag ) ;
797          else                      sprintf(memord,"0") ;
798
799        passes = 1 ;
800        if ( fourdname != NULL ) passes = 2 ;
801        for ( pass = 0 ; pass < passes ; pass++ ) {
802          tend_tag = ( pass == 0 ) ? "_B" : "_BT" ;
803          if ( sw_io == GEN_INPUT )
804          {
805            if ( ok_to_collect_distribute )
806              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
807            fprintf(fp,"CALL wrf_ext_read_field (  &\n") ;
808            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
809            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
810            if ( fourdname == NULL ) {
811              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
812              if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
813                fprintf(fp,"                       %s%s%s(%s,kds,1)     , &  ! Field \n" , structname , p->name, bdy_indicator(ibdy), ms1 ) ;
814              } else {
815                fprintf(fp,"                       %s%s(1,kds,1,%d)     , &  ! Field \n" , structname , p->name, ibdy ) ;
816              }
817            } else {
818              if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag)  ; }
819              else                                                { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
820              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
821              if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
822                fprintf(fp,"                       %s%s%s%s(%s,kds,1,P_%s)     , &  ! Field \n" , 
823                         structname , fourdname, tend_tag, bdy_indicator(ibdy), ms1, p->name ) ;
824              } else {
825                fprintf(fp,"                       %s%s%s(1,kds,1,%d,P_%s)     , &  ! Field \n" , 
826                         structname , fourdname, tend_tag, ibdy, p->name ) ;
827              }
828            }
829            if (!strncmp(p->type->name,"real",4)) {
830              fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
831            } else {
832              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
833            }
834            fprintf(fp,"                       grid%%communicator , &  ! Comm\n") ;
835            fprintf(fp,"                       grid%%iocommunicator , &  ! Comm\n") ;
836            fprintf(fp,"                       grid%%domdesc      , &  ! Comm\n") ;
837            fprintf(fp,"                       grid%%bdy_mask     , &  ! bdy_mask\n" ) ;
838            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
839            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
840            fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
841            /* global dimensions */
842            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
843            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
844            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
845            fprintf(fp,"                       ierr )\n") ;
846            if ( ok_to_collect_distribute )
847            {
848              fprintf(fp,"ENDIF\n") ;
849              fprintf(fp,"CALL wrf_dm_bcast_%s ( %s%s ( 1, 1 , 1 , %d ) , &\n",p->type->name, structname , p->name, ibdy) ;
850              fprintf(fp," ((%s)-(%s)+1)*((%s)-(%s)+1)*((%s)-(%s)+1)  )\n",me1,ms1,me2,ms2,me3,ms3)  ;
851            }
852          }
853          else if ( sw_io == GEN_OUTPUT )
854          {
855            if ( ok_to_collect_distribute )
856              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
857            fprintf(fp,"CALL wrf_ext_write_field (  &\n") ;
858            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
859            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
860            if ( fourdname == NULL ) {
861              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
862              if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
863                fprintf(fp,"                       %s%s%s(%s,kds,1)     , &  ! Field \n" , structname , p->name, bdy_indicator(ibdy), ms1 ) ;
864              } else {
865                fprintf(fp,"                       %s%s(1,kds,1,%d)     , &  ! Field \n" , structname , p->name, ibdy ) ;
866              }
867            } else {
868              if ( strlen(p->dname)==0 || !strcmp(p->dname,"-") ) { sprintf(dname,"%s%s%s",p->name,tend_tag,bdytag)  ; }
869              else                                                { sprintf(dname,"%s%s%s",p->dname,tend_tag,bdytag) ; }
870              fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
871              if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */
872                fprintf(fp,"                       %s%s%s%s(%s,kds,1,P_%s)     , &  ! Field \n" , 
873                                       structname , fourdname, tend_tag, ms1, bdy_indicator(ibdy), p->name ) ;
874              } else {
875                fprintf(fp,"                       %s%s%s%s(1,kds,1,%d,P_%s)     , &  ! Field \n" , 
876                                       structname , fourdname, tend_tag, ibdy, bdy_indicator(ibdy), p->name ) ;
877              }
878            }
879            if (!strncmp(p->type->name,"real",4)) {
880              fprintf(fp,"                       WRF_FLOAT          , &  ! FieldType \n") ;
881            } else {
882              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
883            }
884            fprintf(fp,"                       grid%%communicator , &  ! Comm\n") ;
885            fprintf(fp,"                       grid%%iocommunicator , &  ! Comm\n") ;
886            fprintf(fp,"                       grid%%domdesc      , &  ! Comm\n") ;
887            fprintf(fp,"                       grid%%bdy_mask     , &  ! bdy_mask\n" ) ;
888            fprintf(fp,"                       dryrun             , &  ! flag\n" ) ;
889            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
890            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
891            fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
892            fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
893            fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
894            fprintf(fp,"                       '%s'               , &  ! Desc  \n",p->descrip ) ;
895            fprintf(fp,"                       '%s'               , &  ! Units \n",p->units ) ;
896            fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
897            /* global dimensions */
898            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ds1,de1,ds2,de2,ds3,de3 ) ;
899            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ms1,me1,ms2,me2,ms3,me3 ) ;
900            fprintf(fp,"%s, %s, %s, %s, %s, %s, &\n",ps1,pe1,ps2,pe2,ps3,pe3 ) ;
901            fprintf(fp,"                       ierr )\n") ;
902            if ( ok_to_collect_distribute )
903              fprintf(fp,"ENDIF\n") ;
904          }
905        }
906        }
907      }
908
909/* ////////  NOT BOUNDARY ///////////////////// */
910     else if ( (p->io_mask & io_mask) && ! (io_mask & BOUNDARY))
911     {
912
913/* Aug 2004
914
915Namelist variables
916
917The i r and h settings will be reenabled but it will work a little
918differently than i/o of regular state variables:
919
9201) rather than being read or written as records to the dataset, they
921will be gotten or put as time invariant meta data; in other words, they
922will only be written once when the dataset is created as the other
923metadata is now. This has the benefit of reducing the amount of I/O
924traffic on each write (I can't remember, but that may be why the
925reading and writing of rconfig data was turned off in the first
926place).
927
9282) All the rconfig variables will be gotten/put as metadata to input,
929restart, history, and boundary datasets, regardless of what the 'i',
930'r', and 'h' settings are.  Instead those settings will control the
931behavior with respect to the input-from-namelist vs input-from-dataset
932precedence issue that Bill raised.
933
934In other words, if an rconfig entry has an 'i', 'r', or 'h' in the
935Registry, the dataset value takes precedence over the namelist value.
936Otherwise, say it is missing the 'i', the reconfig variable's value
937still appears as metadata in the dataset but the value of the variable
938in the program does not change as a result of inputting the dataset.
939
940*/
941
942      if ( (p->node_kind & RCONFIG) && ( io_mask & METADATA ) )
943      {
944        char c ;
945        char dname[NAMELEN] ;
946
947        strcpy( dname, p->dname ) ; 
948        make_upper_case( dname ) ;
949        if      ( !strcmp( p->type->name , "integer" )         ) { c = 'i' ; }
950        else if ( !strcmp( p->type->name , "real" )            ) { c = 'r' ; }
951        else if ( !strcmp( p->type->name , "doubleprecision" ) ) { c = 'd' ; }
952        else if ( !strcmp( p->type->name , "logical" )         ) { c = 'l' ; }
953        else {
954          fprintf(stderr,"REGISTRY WARNING: unknown type %s for %s\n",p->type->name,p->name ) ;
955        }
956        if ( sw_io == GEN_OUTPUT ) {
957          if ( io_mask & p->io_mask ) {
958            fprintf(fp,"CALL rconfig_get_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
959            fprintf(fp," CALL wrf_put_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
960          }
961        } else {
962          if ( io_mask & p->io_mask ) {
963            fprintf(fp,"CALL wrf_get_dom_ti_%s ( fid , '%s', %cbuf(1), 1, ierr )\n",p->type->name,dname,c) ;
964            fprintf(fp," WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_%s for %s returns ',%cbuf(1)\n",p->type->name,dname,c) ;
965            fprintf(fp," CALL wrf_debug ( 300 , wrf_err_message )\n") ;
966            fprintf(fp," CALL rconfig_set_%s ( grid%%id, %cbuf(1) )\n",p->name,c) ;
967          }
968        }
969      }
970/* end Aug 2004 */
971#if 0
972      else if ( ! (io_mask & METADATA) )   /* state vars */
973#else
974      else if ( ! (io_mask & METADATA) && ! (p->node_kind & RCONFIG) )   /* state vars */
975#endif
976      {
977        if ( io_mask & RESTART && p->ntl > 1 ) passes = p->ntl ;
978        else                                   passes = 1 ;
979
980        for ( pass = 0 ; pass < passes ; pass++ )   /* for multi timelevel vars */
981        {
982                  /* for multi time level variables gen read for both levels
983                     for restart, only _2 for others */
984          if ( p->ntl > 1 ) {
985            if ( io_mask & RESTART ) sprintf(tag,"_%d",pass+1) ;
986            else                     sprintf(tag,"_%d",p->ntl) ;
987          }
988          else              sprintf(tag,"") ; 
989
990          /* construct variable name */
991          if ( p->scalar_array_member )
992          {
993            strcpy(dexes,"") ;
994            for (ii = 0; ii < p->ndims; ii++ )
995            {
996              switch(p->dims[ii]->coord_axis)
997              {
998              case(COORD_X): strcat(dexes,"ims,") ; break ;
999              case(COORD_Y): strcat(dexes,"jms,") ; break ;
1000              case(COORD_Z): strcat(dexes,"kms,") ; break ;
1001              default : break ;
1002              }
1003            }
1004            sprintf(vname,"%s%s(%sP_%s)",p->use,tag,dexes,p->name) ;
1005            sprintf(vname_2,"%s%s(%sP_%s)",p->use,"_2",":,:,:,",p->name) ;
1006            sprintf(vname_1,"%s%s(%sP_%s)",p->use,"_1",":,:,:,",p->name) ;
1007            sprintf(vname_x,"%s%s(%sP_%s)",p->use,tag,":,:,:,",p->name) ;
1008          }
1009          else
1010          {
1011            sprintf(vname,"%s%s",p->name,tag) ;
1012            sprintf(vname_x,"%s%s",p->name,tag) ;
1013            sprintf(vname_1,"%s%s",p->name,"_1") ;
1014            sprintf(vname_2,"%s%s",p->name,"_2") ;
1015          }
1016
1017
1018          /* construct data name -- maybe same as vname if dname not spec'd  */
1019          if ( strlen(p->dname) == 0 || !strcmp(p->dname,"-") ) { strcpy(dname_tmp,p->name) ; }
1020          else                                                  { strcpy(dname_tmp,p->dname) ; }
1021          make_upper_case(dname_tmp) ;
1022
1023/*
1024   July 2004
1025
1026   New code to generate error if input or output for two state variables would be generated with the same dataname
1027
1028   example wrong:
1029     misc    tg      "SOILTB"   -> gen_tg,SOILTB
1030     misc    soiltb  "SOILTB"   -> gen_soiltb,SOILTB
1031
1032*/
1033if ( pass == 0 )
1034{
1035          char dname_symbol[128] ;
1036          sym_nodeptr sym_node ;
1037
1038          sprintf(dname_symbol, "DNAME_%s", dname_tmp ) ;
1039          /* check and see if it is in the symbol table already */
1040
1041          if ((sym_node = sym_get( dname_symbol )) == NULL ) {
1042            /* add it */
1043            sym_node = sym_add ( dname_symbol ) ;
1044            strcpy( sym_node->internal_name , p->name ) ;
1045          } else {
1046            fprintf(stderr,"REGISTRY ERROR: Data-name collision on %s for %s \n",
1047              dname_tmp,p->name ) ;
1048          }
1049}
1050/* end July 2004 */
1051
1052          if ( io_mask & RESTART &&  p->ntl > 1 ) sprintf(dname,"%s_%d",dname_tmp,pass+1) ;
1053          else                                    strcpy(dname,dname_tmp) ;
1054
1055          set_mem_order( p, memord , NAMELEN) ;
1056
1057/* kludge for WRF 3DVAR I/O with MM5 analysis kernel */
1058          if ( sw_3dvar_iry_kludge && !strcmp(memord,"XYZ") ) sprintf(memord,"YXZ") ;
1059          if ( sw_3dvar_iry_kludge && !strcmp(memord,"XY") ) sprintf(memord,"YX") ;
1060
1061          if ( strlen(dname) < 1 ) {
1062            fprintf(stderr,"gen_wrf_io.c: Registry WARNING:: no data name for %s \n",p->name) ;
1063          }
1064          if ( p->io_mask & io_mask && sw_io == GEN_INPUT )
1065          {
1066            if ( p->scalar_array_member )
1067              fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1068            if ( ok_to_collect_distribute )
1069              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1070
1071            strcpy(indices,"") ;
1072            sprintf(post,")") ;
1073            if ( sw_io_deref_kludge && !(p->scalar_array_member) )   /* these aready have */
1074            {
1075              sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ;
1076            }
1077
1078            fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s') ) THEN\n",vname) ;
1079            fprintf(fp,"CALL wrf_ext_read_field (  &\n") ;
1080            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
1081            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
1082            fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
1083            if ( p->ndims >= 2 && ok_to_collect_distribute )
1084              fprintf(fp,"                       globbuf_%s               , &  ! Field \n" , p->type->name ) ;
1085            else
1086              fprintf(fp,"                       %s%s%s               , &  ! Field \n" , structname , vname , indices) ;
1087
1088            if (!strncmp(p->type->name,"real",4)) {
1089              fprintf(fp,"                       WRF_FLOAT             , &  ! FieldType \n") ;
1090            } else {
1091              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
1092            }
1093
1094            fprintf(fp,"                       grid%%communicator  , &  ! Comm\n") ;
1095            fprintf(fp,"                       grid%%iocommunicator  , &  ! Comm\n") ;
1096            fprintf(fp,"                       grid%%domdesc       , &  ! Comm\n") ;
1097            fprintf(fp,"                       grid%%bdy_mask     , &  ! bdy_mask\n") ;
1098            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
1099            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
1100            fprintf(fp,"'%s ext_read_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1101            /* global dimensions */
1102            for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1103            fprintf(fp," & \n") ;
1104
1105/* the first two cases here have to do with if we're running on multiple distributed
1106   memory processors and the i/o api layer can't handle decomposed data. So code is
1107   generated to read the data on processor zero into a globally sized buffer. In this
1108   case, then the domain, memory, and patch dimensions for the globally sized buffer
1109   are all just the domain dimensions. Two D arrays are handled separately
1110   from three-d arrays because in threeD arrays the middle index is K.  In the last
1111   case, where the code is either calling a version of the API that supports parallelism
1112   or we aren't running in DM-parallel, the field itself and not a global buffer are
1113   passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1114
1115            if      ( p->ndims == 3 && ok_to_collect_distribute )
1116            {
1117              /* mem    dimensions are actually domain dimensions */
1118              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1119              fprintf(fp," & \n") ;
1120              /* patch  dimensions are actually domain dimensions */
1121              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim   [i][0], ddim   [i][1]) ; }
1122              fprintf(fp," & \n") ;
1123            }
1124            else if ( p->ndims == 2 && ok_to_collect_distribute )
1125            {
1126              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1127              {
1128                /* mem    dimensions are actually domain dimensions */
1129                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1130                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1131              /* patch  dimensions are actually domain dimensions */
1132                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim   [xi][0],ddim   [xi][1],
1133                                                          ddim   [yi][0],ddim   [yi][1] ) ;
1134              }
1135            }
1136            else
1137            {
1138              /* mem    dimensions */
1139              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1140              fprintf(fp," & \n") ;
1141              /* patch  dimensions */
1142              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1143              fprintf(fp," & \n") ;
1144            }
1145            fprintf(fp,"                       ierr )\n") ;
1146            fprintf(fp,"END IF\n" ) ;
1147
1148            if ( ok_to_collect_distribute )
1149              fprintf(fp,"END IF\n" ) ;
1150
1151/* In case we have read into a global buffer, generate code to distribute the data just read in */
1152            if      ( p->ndims == 3 && ok_to_collect_distribute )
1153            {
1154              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)
1155              {
1156                fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1157                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1158                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1159                                                          ddim_no[yi][0],ddim_no[yi][1],
1160                                                          ddim_no[zi][0],ddim_no[zi][1]) ;
1161                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1162                                                          mdim_no[yi][0],mdim_no[yi][1],
1163                                                          mdim_no[zi][0],mdim_no[zi][1]) ;
1164                fprintf(fp, "%s, %s, %s, %s, %s, %s  )\n",pdim_no[xi][0],pdim_no[xi][1],
1165                                                          pdim_no[yi][0],pdim_no[yi][1],
1166                                                          pdim_no[zi][0],pdim_no[zi][1]) ;
1167              }
1168            }
1169            else if ( p->ndims == 2 && ok_to_collect_distribute )
1170            {
1171              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1172              {
1173                fprintf(fp,"call wrf_global_to_patch_%s ( globbuf_%s , %s%s , &\n",p->type->name,p->type->name,structname , vname ) ;
1174                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1175                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1176                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1177                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1178                                                          mdim_no[yi][0],mdim_no[yi][1] ) ;
1179                fprintf(fp, "%s, %s, %s, %s, 1 , 1   )\n",pdim_no[xi][0],pdim_no[xi][1],
1180                                                          pdim_no[yi][0],pdim_no[yi][1] ) ;
1181              }
1182              else
1183              {
1184                fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1185              }
1186            }
1187            else if ( !strcmp(memord,"Z") && ok_to_collect_distribute )
1188            {
1189              fprintf(fp," call wrf_dm_bcast_%s ( %s%s , (%s)-(%s)+1 )\n",p->type->name,structname,vname,ddim[0][1],ddim[0][0] ) ;
1190            }
1191            else if ( !strcmp(memord,"0") && ok_to_collect_distribute )
1192            {
1193              fprintf(fp," call wrf_dm_bcast_%s ( %s%s , 1 )\n",p->type->name,structname,vname ) ;
1194
1195            }
1196            else if ( ok_to_collect_distribute )
1197            {
1198              fprintf(stderr,"gen_wrf_io.c: Registry WARNING: can't figure out entry for %s (Memord %s)\n",p->name,memord) ;
1199            }
1200
1201            if ( io_mask & INPUT && p->ntl > 1 ) {
1202              /* copy time level two into time level one */
1203              if ( p->ntl == 3 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_2 , vname_x ) ;
1204              if ( p->ntl == 2 ) fprintf(fp, "grid%%%s = grid%%%s\n", vname_1 , vname_x ) ;
1205            }
1206
1207            if ( p->scalar_array_member )
1208            {
1209              fprintf(fp,"END IF\n" ) ;
1210            }
1211
1212          }
1213          else if ( sw_io == GEN_OUTPUT )
1214          {
1215            if ( p->scalar_array_member )
1216              fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1217
1218/* Genereate code to write into a global buffer if it's DM-parallel and I/O API cannot handle distributed data  */
1219
1220            if      ( p->ndims == 3 && ok_to_collect_distribute )
1221            {
1222              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)
1223              {
1224                fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1225                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1226/*              fprintf(fp, "ids , ide , jds , jde , kds , kde ,                &\n")  ; */
1227                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",ddim_no[xi][0],ddim_no[xi][1],
1228                                                          ddim_no[yi][0],ddim_no[yi][1],
1229                                                          ddim_no[zi][0],ddim_no[zi][1]) ;
1230                fprintf(fp, "%s, %s, %s, %s, %s, %s, &\n",mdim_no[xi][0],mdim_no[xi][1],
1231                                                          mdim_no[yi][0],mdim_no[yi][1],
1232                                                          mdim_no[zi][0],mdim_no[zi][1]) ;
1233                fprintf(fp, "%s, %s, %s, %s, %s, %s  )\n",pdim_no[xi][0],pdim_no[xi][1],
1234                                                          pdim_no[yi][0],pdim_no[yi][1],
1235                                                          pdim_no[zi][0],pdim_no[zi][1]) ;
1236              }
1237            }
1238            else if ( p->ndims == 2 && ok_to_collect_distribute )
1239            {
1240              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1241              {
1242                fprintf(fp,"IF ( .NOT. dryrun ) call wrf_patch_to_global_%s ( %s%s , globbuf_%s , &\n",p->type->name,structname,vname,p->type->name ) ;
1243                fprintf(fp,"       grid%%domdesc, %d, &\n",p->ndims) ;
1244/*              fprintf(fp, "ids , ide , jds , jde , 1 , 1 ,                &\n")  ; */
1245                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1246                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1247                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",mdim_no[xi][0],mdim_no[xi][1],
1248                                                          mdim_no[yi][0],mdim_no[yi][1] ) ;
1249                fprintf(fp, "%s, %s, %s, %s, 1 , 1   )\n",pdim_no[xi][0],pdim_no[xi][1],
1250                                                          pdim_no[yi][0],pdim_no[yi][1] ) ;
1251              }
1252              else
1253              {
1254                fprintf(stderr,"gen_wrf_io.c: Registry WARNING (and possibly internal error) %s \n",p->name) ;
1255              }
1256            }
1257         
1258            for ( i = 0 ; i < 3 ; i++ ) strcpy(dimname[i],"") ;
1259            for ( i = 0 ; i < 3 ; i++ ) 
1260            {
1261              if (( dimnode = p->dims[i]) != NULL )
1262              {
1263                switch ( dimnode->coord_axis )
1264                {
1265                case (COORD_X) : 
1266                  if ( ( ! sw_3dvar_iry_kludge && p->stag_x ) || ( sw_3dvar_iry_kludge && p->stag_y ) )
1267                   { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } 
1268                  else if ( p->dims[i]->subgrid ) 
1269                   { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1270                  else 
1271                   { strcpy( dimname[i], dimnode->dim_data_name) ; }
1272                  break ;
1273                case (COORD_Y) : 
1274                  if ( ( ! sw_3dvar_iry_kludge && p->stag_y ) || ( sw_3dvar_iry_kludge && p->stag_x ) )
1275                   { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } 
1276                  else if ( p->dims[i]->subgrid ) 
1277                   { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1278                  else 
1279                   { strcpy( dimname[i], dimnode->dim_data_name) ; }
1280                  break ;
1281                case (COORD_Z) : 
1282                  if ( p->stag_z ) 
1283                   { sprintf( dimname[i] ,"%s_stag", dimnode->dim_data_name) ; } 
1284                  else if ( p->dims[i]->subgrid ) 
1285                   { sprintf( dimname[i] ,"%s_subgrid", dimnode->dim_data_name) ; }
1286                  else 
1287                   { strcpy( dimname[i], dimnode->dim_data_name) ; }
1288                  break ;
1289                }
1290              }
1291            }
1292
1293            if ( ok_to_collect_distribute )
1294              fprintf(fp,"IF ( wrf_dm_on_monitor() ) THEN\n") ;
1295
1296            strcpy(indices,"") ;
1297            sprintf(post,")") ;
1298            if ( sw_io_deref_kludge && !(p->scalar_array_member) )   /* these aready have */
1299            {
1300              sprintf(indices, "%s",index_with_firstelem("(","grid%",-1,t2,p,post)) ;
1301            }
1302
1303  if ( !(p->scalar_array_member) ) {
1304            fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s') ) THEN\n",vname) ;
1305            fprintf(fp,"CALL wrf_ext_write_field (  &\n") ;
1306            fprintf(fp,"                       fid                , &  ! DataHandle \n" ) ;
1307            fprintf(fp,"                       current_date(1:19) , &  ! DateStr \n" ) ;
1308            fprintf(fp,"                       '%s'               , &  ! Data Name \n", dname ) ;
1309            if ( p->ndims >= 2 && ok_to_collect_distribute )
1310              fprintf(fp,"                       globbuf_%s               , &  ! Field \n" , p->type->name ) ;
1311            else
1312              fprintf(fp,"                       %s%s%s               , &  ! Field \n" , structname , vname , indices ) ;
1313            if (!strncmp(p->type->name,"real",4)) {
1314              fprintf(fp,"                       WRF_FLOAT          , &  ! FieldType \n") ;
1315            } else {
1316              fprintf(fp,"                       WRF_%s             , &  ! FieldType \n" , p->type->name ) ;
1317            }
1318            fprintf(fp,"                       grid%%communicator  , &  ! Comm\n") ;
1319            fprintf(fp,"                       grid%%iocommunicator  , &  ! Comm\n") ;
1320            fprintf(fp,"                       grid%%domdesc       , &  ! Comm\n") ;
1321            fprintf(fp,"                       grid%%bdy_mask       , &  ! bdy_mask\n") ;
1322            fprintf(fp,"                       dryrun             , &  ! flag\n" ) ;
1323            fprintf(fp,"                       '%s'               , &  ! MemoryOrder\n",memord ) ;
1324            fprintf(fp,"                       '%s'               , &  ! Stagger\n",stagstr ) ;
1325            fprintf(fp,"                       '%s'               , &  ! Dimname 1 \n",dimname[0] ) ;
1326            fprintf(fp,"                       '%s'               , &  ! Dimname 2 \n",dimname[1] ) ;
1327            fprintf(fp,"                       '%s'               , &  ! Dimname 3 \n",dimname[2] ) ;
1328            fprintf(fp,"                       '%s'               , &  ! Desc  \n",p->descrip ) ;
1329            fprintf(fp,"                       '%s'               , &  ! Units \n",p->units ) ;
1330            fprintf(fp,"'%s ext_write_field %s memorder %s' , & ! Debug message\n",fname,dname,memord ) ;
1331            /* global dimensions */
1332            for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1333            fprintf(fp," & \n") ;
1334
1335/* the first two cases here have to do with if we're running on multiple distributed
1336   memory processors and the i/o api layer can't handle decomposed data. So code is
1337   generated to read the data on processor zero into a globally sized buffer. In this
1338   case, then the domain, memory, and patch dimensions for the globally sized buffer
1339   are all just the domain domain dimensions. Two D arrays are handled separately
1340   from three-d arrays because in threeD arrays the middle index is K.  In the last
1341   case, where the code is either calling a version of the API that supports parallelism
1342   or we aren't running in DM-parallel, the field itself and not a global buffer are
1343   passed, so we pass the domain, memory, and patch indices directly to the read routine. */
1344
1345            if      ( p->ndims == 3 && ok_to_collect_distribute )
1346            {
1347              /* mem    dimensions are actually domain dimensions */
1348              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim_no[i][0], ddim_no[i][1]) ; }
1349              fprintf(fp," & \n") ;
1350              /* patch  dimensions are actually domain dimensions */
1351              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",ddim[i][0], ddim[i][1]) ; }
1352              fprintf(fp," & \n") ;
1353            }
1354            else if ( p->ndims == 2 && ok_to_collect_distribute )
1355            {
1356              if ((xi=get_index_for_coord(p,COORD_X))>=0&&(yi=get_index_for_coord(p,COORD_Y))>=0)
1357              {
1358                /* mem    dimensions are actually domain dimensions */
1359                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim_no[xi][0],ddim_no[xi][1],
1360                                                          ddim_no[yi][0],ddim_no[yi][1] ) ;
1361              /* patch  dimensions are actually domain dimensions */
1362                fprintf(fp, "%s, %s, %s, %s, 1 , 1 , &\n",ddim[xi][0],ddim[xi][1],
1363                                                          ddim[yi][0],ddim[yi][1] ) ;
1364              }
1365            }
1366            else
1367            {
1368              /* mem    dimensions */
1369              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",mdim[i][0], mdim[i][1]) ; }
1370              fprintf(fp," & \n") ;
1371              /* patch  dimensions */
1372              for ( i = 0 ; i < 3 ; i++ ) { fprintf(fp,"%s , %s , ",pdim[i][0], pdim[i][1]) ; }
1373              fprintf(fp," & \n") ;
1374            }
1375            fprintf(fp,"                       ierr )\n") ;
1376            fprintf(fp,"ENDIF\n") ;
1377
1378            if ( ok_to_collect_distribute )
1379              fprintf(fp,"END IF\n" ) ;
1380
1381/*
1382            if ( p->scalar_array_member )
1383              fprintf(fp,"END IF\n" ) ;
1384*/
1385
1386  }
1387          }
1388        }
1389      }
1390    }
1391    }
1392    if ( p->type->type_type == DERIVED )
1393    {
1394      sprintf(x,"%s%s%%",structname,p->name ) ;
1395      gen_wrf_io2(fp, fname, x, NULL, p->type, io_mask, sw_io ) ;
1396    }
1397
1398    }
1399  }
1400  return(0) ;
1401}
1402
Note: See TracBrowser for help on using the repository browser.