?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
merge standard release WRF/WPS V3.0.1.1 into wrffire
[wrffire.git] / wrfv2_fire / external / RSL_LITE / gen_comms.c
blobd57ce904be3cb9b5d02b8c6e80963348d5ce9b37
1 #include <stdio.h>
2 #include <stdlib.h>
3 #include <string.h>
4
5 #include "protos.h"
6 #include "registry.h"
7 #include "data.h"
8
9 /* For detecting variables that are members of a derived type */
10 #define NULLCHARPTR (char *) 0
11 static int parent_type;
12
13 /* print actual and dummy arguments and declarations for 4D and i1 arrays */
14 int print_4d_i1_decls ( FILE *fp , node_t *p, int ad /* 0=argument,1=declaration */ )
15 {
16 node_t * q ;
17 node_t * dimd ;
18 char fname[NAMELEN] ;
19 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
20 char commuse[NAMELEN] ;
21 int maxstenwidth, stenwidth ;
22 char * t1, * t2 , *wordsize ;
23 char varref[NAMELEN] ;
24 char * pos1 , * pos2 ;
25 char * dimspec ;
26 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
27 int zdex ;
28
29 set_mark( 0, Domain.fields ) ;
30
31 strcpy( tmp, p->comm_define ) ;
32 strcpy( commuse, p->use ) ;
33 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
34 while ( t1 != NULL )
35 {
36 strcpy( tmp2 , t1 ) ;
37 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
38 {
39 fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ;
40 }
41 t2 = strtok_rentr(NULL,",", &pos2) ;
42 while ( t2 != NULL )
43 {
44 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
45 { fprintf(stderr,"WARNING 1a : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
46 else
47 {
48 strcpy( varref, t2 ) ;
49 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
50 sprintf(varref,"grid%%%s",t2) ;
51 }
52
53 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
54 else if ( q->boundary_array ) { ; }
55 else
56 {
57 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
58 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
59 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
60 if ( q->node_kind & FOURD )
61 {
62 node_t *member ;
63 zdex = get_index_for_coord( q , COORD_Z ) ;
64 if ( zdex >=1 && zdex <= 3 )
65 {
66 set_mem_order( q->members, memord , NAMELEN) ;
67 if ( ad == 0 )
68 /* acutal or dummy argument */
69 {
70 /* explicit dummy or actual arguments for 4D arrays */
71 if ( q->mark == 0 ) {
72 fprintf(fp," num_%s, &\n",q->name) ;
73 q->mark = 1 ;
74 }
75 fprintf(fp," %s, &\n",varref) ;
76 }
77 else
78 {
79 /* declaration of dummy arguments for 4D arrays */
80 if ( q->mark == 0 ) {
81 fprintf(fp," INTEGER, INTENT(IN) :: num_%s\n",q->name) ;
82 q->mark = 1 ;
83 }
84 fprintf(fp," %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33,num_%s)\n",
85 q->type->name , varref , q->name ) ;
86 }
87 }
88 else
89 {
90 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
91 }
92 }
93 else if ( q->node_kind & I1 )
94 {
95 if ( ad == 0 )
96 {
97 /* explicit dummy or actual arguments for i1 arrays */
98 fprintf(fp," %s, &\n",varref) ;
99 }
100 else
101 {
102 /* declaration of dummy arguments for i1 arrays */
103 strcpy(tmp3,"") ;
104 dimspec=dimension_with_ranges( "grid%","(",-1,tmp3,q,")","" ) ;
105 fprintf(fp," %s, INTENT(INOUT) :: %s %s\n", q->type->name , varref , dimspec ) ;
106 }
107 }
108 }
109 }
110 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
111 }
112 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
113 }
114 }
115
116 int print_call_or_def( FILE * fp , node_t *p, char * callorsub,
117 char * commname, char * communicator,
118 int need_config_flags )
119 {
120 fprintf(fp,"%s %s_sub ( grid, &\n",callorsub,commname) ;
121 if (need_config_flags == 1)
122 fprintf(fp," config_flags, &\n") ;
123 print_4d_i1_decls( fp, p, 0 );
124 fprintf(fp," %s, &\n",communicator) ;
125 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
126 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
127 fprintf(fp," ims, ime, jms, jme, kms, kme, &\n") ;
128 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
129 return(0) ;
130 }
131
132 int print_decl( FILE * fp , node_t *p, char * communicator,
133 int need_config_flags )
134 {
135 fprintf(fp," USE module_domain, ONLY:domain\n") ;
136 fprintf(fp," USE module_configure, ONLY:grid_config_rec_type,in_use_for_config\n") ;
137 fprintf(fp," USE module_state_description, ONLY:PARAM_FIRST_SCALAR\n") ;
138 fprintf(fp," USE module_driver_constants\n") ;
139 fprintf(fp," TYPE(domain) , INTENT(IN) :: grid\n") ;
140 if (need_config_flags == 1)
141 fprintf(fp," TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags\n") ;
142 print_4d_i1_decls( fp, p, 1 );
143 fprintf(fp," INTEGER , INTENT(IN) :: %s\n",communicator) ;
144 fprintf(fp," INTEGER , INTENT(IN) :: mytask, ntasks, ntasks_x, ntasks_y\n") ;
145 fprintf(fp," INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde\n") ;
146 fprintf(fp," INTEGER , INTENT(IN) :: ims, ime, jms, jme, kms, kme\n") ;
147 fprintf(fp," INTEGER , INTENT(IN) :: ips, ipe, jps, jpe, kps, kpe\n") ;
148 fprintf(fp," INTEGER :: itrace\n") ;
149 }
150
151 int print_body( FILE * fp, char * commname )
152 {
153 fprintf(fp," \n") ;
154 fprintf(fp,"#ifdef DM_PARALLEL\n") ;
155 fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ;
156 fprintf(fp,"#endif\n") ;
157 fprintf(fp," \n") ;
158 fprintf(fp," END SUBROUTINE %s_sub\n",commname) ;
159 }
160
161 int
162 gen_halos ( char * dirname , char * incname , node_t * halos )
163 {
164 node_t * p, * q ;
165 node_t * dimd ;
166 char commname[NAMELEN] ;
167 char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
168 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
169 char commuse[NAMELEN] ;
170 #define MAX_VDIMS 100
171 char vdims[MAX_VDIMS][2][80] ;
172 char s[NAMELEN], e[NAMELEN] ;
173 int vdimcurs ;
174 int maxstenwidth, stenwidth ;
175 FILE * fp ;
176 FILE * fpcall ;
177 FILE * fpsub ;
178 char * t1, * t2 ;
179 char * pos1 , * pos2 ;
180 char indices[NAMELEN], post[NAMELEN] ;
181 int zdex ;
182 int n2dR, n3dR ;
183 int n2dI, n3dI ;
184 int n2dD, n3dD ;
185 int n4d ;
186 int i, foundvdim ;
187 int subgrid ;
188 int need_config_flags;
189 #define MAX_4DARRAYS 1000
190 char name_4d[MAX_4DARRAYS][NAMELEN] ;
191
192 if ( dirname == NULL ) return(1) ;
193
194 for ( p = halos ; p != NULL ; p = p->next )
195 {
196 need_config_flags = 0; /* 0 = do not need, 1 = need */
197 if ( incname == NULL ) {
198 strcpy( commname, p->name ) ;
199 make_upper_case(commname) ;
200 }
201 else {
202 strcpy( commname, incname ) ;
203 }
204 if ( incname == NULL ) {
205 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
206 else { sprintf(fname,"%s_inline.inc",commname) ; }
207 /* Generate call to custom routine that encapsulates inlined comm calls */
208 if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
209 else { sprintf(fnamecall,"%s.inc",commname) ; }
210 if ((fpcall = fopen( fnamecall , "w" )) == NULL )
211 {
212 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall ) ;
213 continue ;
214 }
215 print_warning(fpcall,fnamecall) ;
216 /* Generate definition of custom routine that encapsulates inlined comm calls */
217 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_subs.inc",dirname) ; }
218 else { sprintf(fnamesub,"REGISTRY_COMM_DM_subs.inc") ; }
219 if ((fpsub = fopen( fnamesub , "a" )) == NULL )
220 {
221 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub ) ;
222 continue ;
223 }
224 print_warning(fpsub,fnamesub) ;
225 }
226 else {
227 /* for now, retain original behavior when called from gen_shift */
228 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
229 else { sprintf(fname,"%s.inc",commname) ; }
230 }
231 /* Generate inlined comm calls */
232 if ((fp = fopen( fname , "w" )) == NULL )
233 {
234 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
235 continue ;
236 }
237 /* get maximum stencil width */
238 maxstenwidth = 0 ;
239 strcpy( tmp, p->comm_define ) ;
240 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
241 while ( t1 != NULL )
242 {
243 strcpy( tmp2 , t1 ) ;
244 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
245 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
246 stenwidth = atoi (t2) ;
247 if ( stenwidth == 0 )
248 { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
249 if ( stenwidth == 4 || stenwidth == 8 ) stenwidth = 1 ;
250 else if ( stenwidth == 12 || stenwidth == 24 ) stenwidth = 2 ;
251 else if ( stenwidth == 48 ) stenwidth = 3 ;
252 else if ( stenwidth == 80 ) stenwidth = 4 ;
253 else if ( stenwidth == 120 ) stenwidth = 5 ;
254 else if ( stenwidth == 168 ) stenwidth = 6 ;
255 else
256 { fprintf(stderr,"%s: unknown stenci description or just too big: %d\n", commname, stenwidth ) ; exit(1) ; }
257 if ( stenwidth > maxstenwidth ) maxstenwidth = stenwidth ;
258 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
259 }
260 print_warning(fp,fname) ;
261
262 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
263
264 /* count up the number of 2d and 3d real arrays and their types */
265 n2dR = 0 ; n3dR = 0 ;
266 n2dI = 0 ; n3dI = 0 ;
267 n2dD = 0 ; n3dD = 0 ;
268 n4d = 0 ;
269 vdimcurs = 0 ;
270 subgrid = -1 ; /* watch to make sure we don't mix subgrid fields with non-subgrid fields in same halo */
271 strcpy( tmp, p->comm_define ) ;
272 strcpy( commuse, p->use ) ;
273 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
274 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
275 while ( t1 != NULL )
276 {
277 strcpy( tmp2 , t1 ) ;
278 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
279 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
280 t2 = strtok_rentr(NULL,",", &pos2) ;
281 while ( t2 != NULL )
282 {
283 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
284 { fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
285 else
286 {
287 if ( subgrid == -1 ) { /* first one */
288 subgrid = q->subgrid ;
289 } else if ( subgrid != q->subgrid ) {
290 fprintf(stderr,"SERIOUS WARNING: you are mixing subgrid fields with non-subgrid fields in halo %s\n",commname) ;
291 }
292 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
293 { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of halo exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
294 else if ( q->boundary_array )
295 { fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ; }
296 else
297 {
298
299 /* 20061004 -- collect all the vertical dimensions so we can use a MAX
300 on them when calling RSL_LITE_INIT_EXCH */
301
302 if ( q->ndims == 3 || q->node_kind & FOURD ) {
303 if ((dimd = get_dimnode_for_coord( q , COORD_Z )) != NULL ) {
304 zdex = get_index_for_coord( q , COORD_Z ) ;
305 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
306 strcpy(s,"kps") ;
307 strcpy(e,"kpe") ;
308 }
309 else if ( dimd->len_defined_how == NAMELIST ) {
310 need_config_flags = 1;
311 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
312 strcpy(s,"1") ;
313 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
314 } else {
315 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
316 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
317 }
318 }
319 else if ( dimd->len_defined_how == CONSTANT ) {
320 sprintf(s,"%d",dimd->coord_start) ;
321 sprintf(e,"%d",dimd->coord_end) ;
322 }
323 for ( i = 0, foundvdim = 0 ; i < vdimcurs ; i++ ) {
324 if ( !strcmp( vdims[i][1], e ) ) {
325 foundvdim = 1 ; break ;
326 }
327 }
328 if ( ! foundvdim ) {
329 if (vdimcurs < 100 ) {
330 strcpy( vdims[vdimcurs][0], s ) ;
331 strcpy( vdims[vdimcurs][1], e ) ;
332 vdimcurs++ ;
333 } else {
334 fprintf(stderr,"REGISTRY ERROR: too many different vertical dimensions (> %d).\n", MAX_VDIMS ) ;
335 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_VDIMS\n" ) ;
336 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
337 exit(5) ;
338 }
339 }
340 }
341 }
342
343 if ( q->node_kind & FOURD ) {
344 if ( n4d < MAX_4DARRAYS ) {
345 strcpy( name_4d[n4d], q->name ) ;
346 } else {
347 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
348 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
349 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
350 exit(5) ;
351 }
352 n4d++ ;
353 }
354 else
355 {
356 if ( ! strcmp( q->type->name, "real") ) {
357 if ( q->ndims == 3 ) { n3dR++ ; }
358 else if ( q->ndims == 2 ) { n2dR++ ; }
359 } else if ( ! strcmp( q->type->name, "integer") ) {
360 if ( q->ndims == 3 ) { n3dI++ ; }
361 else if ( q->ndims == 2 ) { n2dI++ ; }
362 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
363 if ( q->ndims == 3 ) { n3dD++ ; }
364 else if ( q->ndims == 2 ) { n2dD++ ; }
365 }
366 }
367 }
368 }
369 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
370 }
371 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
372 }
373
374 /* generate the stencil init statement for Y transfer */
375 #if 0
376 fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %d for Y %s')\n",maxstenwidth,fname) ;
377 #endif
378 if ( subgrid != 0 ) {
379 fprintf(fp,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
380 }
381 fprintf(fp,"CALL RSL_LITE_INIT_EXCH ( local_communicator, %d, &\n",maxstenwidth) ;
382 if ( n4d > 0 ) {
383 fprintf(fp, " %d &\n", n3dR ) ;
384 for ( i = 0 ; i < n4d ; i++ ) {
385 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
386 }
387 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
388 } else {
389 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
390 }
391 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
392 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
393 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
394 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
395 if ( subgrid == 0 ) {
396 fprintf(fp," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
397 for ( i = 0 ; i < vdimcurs ; i++ ) {
398 fprintf(fp,",%s &\n",vdims[i][1] ) ;
399 }
400 fprintf(fp,"))\n") ;
401 } else {
402 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
403 }
404
405 /* generate packs prior to stencil exchange in Y */
406 gen_packs( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator" ) ;
407 /* generate stencil exchange in Y */
408 fprintf(fp," CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
409 /* generate unpacks after stencil exchange in Y */
410 gen_packs( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ;
411
412 /* generate the stencil init statement for X transfer */
413 fprintf(fp,"CALL RSL_LITE_INIT_EXCH ( local_communicator, %d , &\n",maxstenwidth) ;
414 if ( n4d > 0 ) {
415 fprintf(fp, " %d &\n", n3dR ) ;
416 for ( i = 0 ; i < n4d ; i++ ) {
417 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
418 }
419 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
420 } else {
421 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
422 }
423 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
424 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
425 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
426 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
427 if ( subgrid == 0 ) {
428 fprintf(fp," ips, ipe, jps, jpe, kps, MAX(1,1&\n") ;
429 for ( i = 0 ; i < vdimcurs ; i++ ) {
430 fprintf(fp,",%s &\n",vdims[i][1] ) ;
431 }
432 fprintf(fp,"))\n") ;
433 } else {
434 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
435 }
436 /* generate packs prior to stencil exchange in X */
437 gen_packs( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator" ) ;
438 /* generate stencil exchange in X */
439 fprintf(fp," CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
440 /* generate unpacks after stencil exchange in X */
441 gen_packs( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ;
442 if ( subgrid != 0 ) {
443 fprintf(fp,"ENDIF\n") ;
444 }
445 close_the_file(fp) ;
446 if ( incname == NULL ) {
447 /* Finish call to custom routine that encapsulates inlined comm calls */
448 print_call_or_def(fpcall, p, "CALL", commname, "local_communicator", need_config_flags );
449 close_the_file(fpcall) ;
450 /* Generate definition of custom routine that encapsulates inlined comm calls */
451 print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator", need_config_flags );
452 print_decl(fpsub, p, "local_communicator", need_config_flags );
453 print_body(fpsub, commname);
454 close_the_file(fpsub) ;
455 }
456 }
457 return(0) ;
458 }
459
460 gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname )
461 {
462 node_t * q ;
463 node_t * dimd ;
464 char fname[NAMELEN] ;
465 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
466 char commuse[NAMELEN] ;
467 int maxstenwidth, stenwidth ;
468 char * t1, * t2 , *wordsize ;
469 char varref[NAMELEN] ;
470 char varname[NAMELEN] ;
471 char * pos1 , * pos2 ;
472 char indices[NAMELEN], post[NAMELEN], memord[NAMELEN] ;
473 int xdex,ydex,zdex ;
474
475 strcpy( tmp, p->comm_define ) ;
476 strcpy( commuse, p->use ) ;
477 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
478 while ( t1 != NULL )
479 {
480 strcpy( tmp2 , t1 ) ;
481 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
482 { fprintf(stderr,"unparseable description for halo %s\n", p->name ) ; continue ; }
483 t2 = strtok_rentr(NULL,",", &pos2) ;
484 while ( t2 != NULL )
485 {
486 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
487 { fprintf(stderr,"WARNING 1b : %s in halo spec %s (%s) is not defined in registry.\n",t2,p->name, commuse) ; }
488 else
489 {
490
491 strcpy( varname, t2 ) ;
492 strcpy( varref, t2 ) ;
493 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
494 sprintf(varref,"grid%%%s",t2) ;
495 }
496
497 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") ) { ; }
498 else if ( q->boundary_array ) { ; }
499 else
500 {
501 if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; }
502 else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; }
503 else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; }
504 if ( q->node_kind & FOURD )
505 {
506 node_t *member ;
507 zdex = get_index_for_coord( q , COORD_Z ) ;
508 if ( zdex >=1 && zdex <= 3 )
509 {
510 set_mem_order( q->members, memord , NAMELEN) ;
511 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ;
512 xdex = get_index_for_coord( q , COORD_X ) ;
513 ydex = get_index_for_coord( q , COORD_Y ) ;
514 fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
515 fprintf(fp," CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33,itrace), %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n",
516 packname, commname, varref , shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
517 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
518 if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) ||
519 !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) {
520 fprintf(fp,"thisdomain_max_halo_width, &\n") ;
521 }
522 if ( q->subgrid == 0 ) {
523 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
524 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
525 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
526 } else {
527 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
528 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
529 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
530 }
531 fprintf(fp," ENDIF\n") ;
532 fprintf(fp,"ENDDO\n") ;
533 }
534 else
535 {
536 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
537 }
538 }
539 else
540 {
541 set_mem_order( q, memord , NAMELEN) ;
542 if ( q->ndims == 3 ) {
543
544 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
545 xdex = get_index_for_coord( q , COORD_X ) ;
546 ydex = get_index_for_coord( q , COORD_Y ) ;
547 zdex = get_index_for_coord( q , COORD_Z ) ;
548 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
549 if ( dimd != NULL )
550 {
551 char s[256], e[256] ;
552
553 if ( dimd->len_defined_how == DOMAIN_STANDARD ) {
554 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
555 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
556 if ( q->subgrid == 0 ) {
557 fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ;
558 fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ;
559 fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ;
560 } else {
561 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
562 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ;
563 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ;
564 }
565 }
566 else if ( dimd->len_defined_how == NAMELIST )
567 {
568 if ( !strcmp(dimd->assoc_nl_var_s,"1") ) {
569 strcpy(s,"1") ;
570 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
571 } else {
572 sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ;
573 sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ;
574 }
575 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
576 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
577 if ( q->subgrid == 0 ) {
578 fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ;
579 fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ;
580 fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",s,e) ;
581 } else {
582 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
583 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",s,e) ;
584 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",s,e) ;
585 }
586 }
587 else if ( dimd->len_defined_how == CONSTANT )
588 {
589 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
590 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
591 if ( q->subgrid == 0 ) {
592 fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
593 fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ;
594 fprintf(fp,"ips, ipe, jps, jpe, %d, %d )\n",dimd->coord_start,dimd->coord_end) ;
595 } else {
596 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
597 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%d,%d,&\n",dimd->coord_start,dimd->coord_end) ;
598 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%d,%d)\n",dimd->coord_start,dimd->coord_end) ;
599 }
600 }
601 }
602 fprintf(fp,"ENDIF\n") ;
603 } else if ( q->ndims == 2 ) {
604 xdex = get_index_for_coord( q , COORD_X ) ;
605 ydex = get_index_for_coord( q , COORD_Y ) ;
606 fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ;
607 fprintf(fp,"CALL %s ( %s,&\n %s, %d, %s, %d, %d, DATA_ORDER_%s, %d, &\n", packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ;
608 fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ;
609 if ( q->subgrid == 0 ) {
610 fprintf(fp,"ids, ide, jds, jde, 1 , 1 , &\n") ;
611 fprintf(fp,"ims, ime, jms, jme, 1 , 1 , &\n") ;
612 fprintf(fp,"ips, ipe, jps, jpe, 1 , 1 )\n") ;
613 } else {
614 fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ;
615 fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,1,1,&\n") ;
616 fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,1,1)\n") ;
617 }
618 fprintf(fp,"ENDIF\n") ;
619 }
620 }
621 }
622
623 }
624 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
625 }
626 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
627 }
628 }
629
630 int
631 gen_periods ( char * dirname , node_t * periods )
632 {
633 node_t * p, * q ;
634 node_t * dimd ;
635 char commname[NAMELEN] ;
636 char fname[NAMELEN], fnamecall[NAMELEN], fnamesub[NAMELEN] ;
637 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
638 char commuse[NAMELEN] ;
639 int maxperwidth, perwidth ;
640 FILE * fp ;
641 FILE * fpcall ;
642 FILE * fpsub ;
643 char * t1, * t2 ;
644 char varref[NAMELEN] ;
645 char * pos1 , * pos2 ;
646 char indices[NAMELEN], post[NAMELEN] ;
647 int zdex ;
648 int n2dR, n3dR ;
649 int n2dI, n3dI ;
650 int n2dD, n3dD ;
651 int n4d ;
652 int i ;
653 #define MAX_4DARRAYS 1000
654 char name_4d[MAX_4DARRAYS][NAMELEN] ;
655
656 if ( dirname == NULL ) return(1) ;
657
658 for ( p = periods ; p != NULL ; p = p->next )
659 {
660 strcpy( commname, p->name ) ;
661 make_upper_case(commname) ;
662 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_inline.inc",dirname,commname) ; }
663 else { sprintf(fname,"%s_inline.inc",commname) ; }
664 /* Generate call to custom routine that encapsulates inlined comm calls */
665 if ( strlen(dirname) > 0 ) { sprintf(fnamecall,"%s/%s.inc",dirname,commname) ; }
666 else { sprintf(fnamecall,"%s.inc",commname) ; }
667 if ((fpcall = fopen( fnamecall , "w" )) == NULL )
668 {
669 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall ) ;
670 continue ;
671 }
672 print_warning(fpcall,fnamecall) ;
673 print_call_or_def(fpcall, p, "CALL", commname, "local_communicator_periodic", 1 );
674 close_the_file(fpcall) ;
675 /* Generate definition of custom routine that encapsulates inlined comm calls */
676 if ( strlen(dirname) > 0 ) { sprintf(fnamesub,"%s/REGISTRY_COMM_DM_subs.inc",dirname) ; }
677 else { sprintf(fnamesub,"REGISTRY_COMM_DM_subs.inc") ; }
678 if ((fpsub = fopen( fnamesub , "a" )) == NULL )
679 {
680 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub ) ;
681 continue ;
682 }
683 print_warning(fpsub,fnamesub) ;
684 print_call_or_def(fpsub, p, "SUBROUTINE", commname, "local_communicator_periodic", 1 );
685 print_decl(fpsub, p, "local_communicator_periodic", 1 );
686 print_body(fpsub, commname);
687 close_the_file(fpsub) ;
688 /* Generate inlined comm calls */
689 if ((fp = fopen( fname , "w" )) == NULL )
690 {
691 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
692 continue ;
693 }
694 /* get maximum period width */
695 maxperwidth = 0 ;
696 strcpy( tmp, p->comm_define ) ;
697 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
698 while ( t1 != NULL )
699 {
700 strcpy( tmp2 , t1 ) ;
701 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
702 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; exit(1) ; }
703 perwidth = atoi (t2) ;
704 if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
705 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
706 }
707 print_warning(fp,fname) ;
708
709 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
710
711 /* count up the number of 2d and 3d real arrays and their types */
712 n2dR = 0 ; n3dR = 0 ;
713 n2dI = 0 ; n3dI = 0 ;
714 n2dD = 0 ; n3dD = 0 ;
715 n4d = 0 ;
716 strcpy( tmp, p->comm_define ) ;
717 strcpy( commuse, p->use ) ;
718 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
719 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
720 while ( t1 != NULL )
721 {
722 strcpy( tmp2 , t1 ) ;
723 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
724 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
725 t2 = strtok_rentr(NULL,",", &pos2) ;
726 while ( t2 != NULL )
727 {
728 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
729 { fprintf(stderr,"WARNING 1 : %s in period spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
730 else
731 {
732 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
733 { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of period exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
734 else if ( q->boundary_array )
735 { fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ; }
736 else
737 {
738 if ( q->node_kind & FOURD ) {
739 if ( n4d < MAX_4DARRAYS ) {
740 strcpy( name_4d[n4d], q->name ) ;
741 } else {
742 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
743 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
744 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
745 exit(5) ;
746 }
747 n4d++ ;
748 }
749 else
750 {
751 if ( ! strcmp( q->type->name, "real") ) {
752 if ( q->ndims == 3 ) { n3dR++ ; }
753 else if ( q->ndims == 2 ) { n2dR++ ; }
754 } else if ( ! strcmp( q->type->name, "integer") ) {
755 if ( q->ndims == 3 ) { n3dI++ ; }
756 else if ( q->ndims == 2 ) { n2dI++ ; }
757 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
758 if ( q->ndims == 3 ) { n3dD++ ; }
759 else if ( q->ndims == 2 ) { n2dD++ ; }
760 }
761 }
762 }
763 }
764 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
765 }
766 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
767 }
768
769 fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
770
771 /* generate the stencil init statement for X transfer */
772 fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
773 if ( n4d > 0 ) {
774 fprintf(fp, " %d &\n", n3dR ) ;
775 for ( i = 0 ; i < n4d ; i++ ) {
776 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
777 }
778 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
779 } else {
780 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
781 }
782 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
783 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
784 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
785 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
786 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
787 /* generate packs prior to exchange in X */
788 gen_packs( fp, p, maxperwidth, 1, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
789 /* generate exchange in X */
790 fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_X ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
791 /* generate unpacks after exchange in X */
792 gen_packs( fp, p, maxperwidth, 1, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
793 fprintf(fp,"END IF\n") ;
794
795
796 fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
797 /* generate the init statement for Y transfer */
798 fprintf(fp,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth) ;
799 if ( n4d > 0 ) {
800 fprintf(fp, " %d &\n", n3dR ) ;
801 for ( i = 0 ; i < n4d ; i++ ) {
802 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
803 }
804 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
805 } else {
806 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
807 }
808 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
809 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
810 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
811 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
812 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
813 /* generate packs prior to exchange in Y */
814 gen_packs( fp, p, maxperwidth, 0, 0, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
815 /* generate exchange in Y */
816 fprintf(fp," CALL RSL_LITE_EXCH_PERIOD_Y ( local_communicator_periodic , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
817 /* generate unpacks after exchange in Y */
818 gen_packs( fp, p, maxperwidth, 0, 1, "RSL_LITE_PACK_PERIOD", "local_communicator_periodic" ) ;
819 fprintf(fp,"END IF\n") ;
820
821 close_the_file(fp) ;
822 }
823 return(0) ;
824 }
825
826 int
827 gen_swaps ( char * dirname , node_t * swaps )
828 {
829 node_t * p, * q ;
830 node_t * dimd ;
831 char commname[NAMELEN] ;
832 char fname[NAMELEN] ;
833 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
834 char commuse[NAMELEN] ;
835 FILE * fp ;
836 char * t1, * t2 ;
837 char * pos1 , * pos2 ;
838 char indices[NAMELEN], post[NAMELEN] ;
839 int zdex ;
840 int n2dR, n3dR ;
841 int n2dI, n3dI ;
842 int n2dD, n3dD ;
843 int n4d ;
844 int i, xy ;
845 #define MAX_4DARRAYS 1000
846 char name_4d[MAX_4DARRAYS][NAMELEN] ;
847
848 if ( dirname == NULL ) return(1) ;
849
850 for ( p = swaps ; p != NULL ; p = p->next )
851 {
852 strcpy( commname, p->name ) ;
853 make_upper_case(commname) ;
854 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
855 else { sprintf(fname,"%s.inc",commname) ; }
856 if ((fp = fopen( fname , "w" )) == NULL )
857 {
858 fprintf(stderr,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname ) ;
859 continue ;
860 }
861 print_warning(fp,fname) ;
862
863 for ( xy = 0 ; xy < 2 ; xy++ ) {
864
865 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
866
867 /* count up the number of 2d and 3d real arrays and their types */
868 n2dR = 0 ; n3dR = 0 ;
869 n2dI = 0 ; n3dI = 0 ;
870 n2dD = 0 ; n3dD = 0 ;
871 n4d = 0 ;
872 strcpy( tmp, p->comm_define ) ;
873 strcpy( commuse, p->use ) ;
874 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
875 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
876 while ( t1 != NULL )
877 {
878 strcpy( tmp2 , t1 ) ;
879 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
880 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
881 t2 = strtok_rentr(NULL,",", &pos2) ;
882 while ( t2 != NULL )
883 {
884 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
885 { fprintf(stderr,"WARNING 1 : %s in swap spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
886 else
887 {
888 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
889 { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of swaps exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
890 else if ( q->boundary_array )
891 { fprintf(stderr,"WARNING: boundary array %s cannot be member of swaps spec %s.\n",t2,commname) ; }
892 else
893 {
894 if ( q->node_kind & FOURD ) {
895 if ( n4d < MAX_4DARRAYS ) {
896 strcpy( name_4d[n4d], q->name ) ;
897 } else {
898 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
899 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
900 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
901 exit(5) ;
902 }
903 n4d++ ;
904 }
905 else
906 {
907 if ( ! strcmp( q->type->name, "real") ) {
908 if ( q->ndims == 3 ) { n3dR++ ; }
909 else if ( q->ndims == 2 ) { n2dR++ ; }
910 } else if ( ! strcmp( q->type->name, "integer") ) {
911 if ( q->ndims == 3 ) { n3dI++ ; }
912 else if ( q->ndims == 2 ) { n2dI++ ; }
913 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
914 if ( q->ndims == 3 ) { n3dD++ ; }
915 else if ( q->ndims == 2 ) { n2dD++ ; }
916 }
917 }
918 }
919 }
920 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
921 }
922 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
923 }
924
925 fprintf(fp,"IF ( config_flags%%swap_%c ) THEN\n",(xy==1)?'x':'y') ;
926
927 /* generate the init statement for X swap */
928 fprintf(fp,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy ) ;
929 if ( n4d > 0 ) {
930 fprintf(fp, " %d &\n", n3dR ) ;
931 for ( i = 0 ; i < n4d ; i++ ) {
932 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
933 }
934 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
935 } else {
936 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
937 }
938 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
939 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
940 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
941 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
942 fprintf(fp," thisdomain_max_halo_width, &\n" ) ;
943 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
944 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
945 /* generate packs prior to stencil exchange */
946 gen_packs( fp, p, 1, xy, 0, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
947 /* generate stencil exchange in X */
948 fprintf(fp," CALL RSL_LITE_SWAP ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
949 /* generate unpacks after stencil exchange */
950 gen_packs( fp, p, 1, xy, 1, "RSL_LITE_PACK_SWAP", "local_communicator" ) ;
951
952 fprintf(fp,"END IF\n") ;
953
954 }
955 close_the_file(fp) ;
956 }
957 return(0) ;
958 }
959
960 int
961 gen_cycles ( char * dirname , node_t * cycles )
962 {
963 node_t * p, * q ;
964 node_t * dimd ;
965 char commname[NAMELEN] ;
966 char fname[NAMELEN] ;
967 char tmp[NAMELEN], tmp2[NAMELEN], tmp3[NAMELEN] ;
968 char commuse[NAMELEN] ;
969 FILE * fp ;
970 char * t1, * t2 ;
971 char * pos1 , * pos2 ;
972 char indices[NAMELEN], post[NAMELEN] ;
973 int zdex ;
974 int n2dR, n3dR ;
975 int n2dI, n3dI ;
976 int n2dD, n3dD ;
977 int n4d ;
978 int i, xy, inout ;
979 #define MAX_4DARRAYS 1000
980 char name_4d[MAX_4DARRAYS][NAMELEN] ;
981
982 if ( dirname == NULL ) return(1) ;
983
984 for ( p = cycles ; p != NULL ; p = p->next )
985 {
986 strcpy( commname, p->name ) ;
987 make_upper_case(commname) ;
988 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
989 else { sprintf(fname,"%s.inc",commname) ; }
990 if ((fp = fopen( fname , "w" )) == NULL )
991 {
992 fprintf(stderr,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname ) ;
993 continue ;
994 }
995
996 /* get inout */
997 inout = 0 ;
998 strcpy( tmp, p->comm_define ) ;
999 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1000 strcpy( tmp2 , t1 ) ;
1001 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1002 { fprintf(stderr,"unparseable description for cycle %s\n", commname ) ; exit(1) ; }
1003 inout = atoi (t2) ;
1004
1005 print_warning(fp,fname) ;
1006
1007 for ( xy = 0 ; xy < 2 ; xy++ ) {
1008
1009 fprintf(fp,"CALL wrf_debug(2,'calling %s')\n",fname) ;
1010
1011 /* count up the number of 2d and 3d real arrays and their types */
1012 n2dR = 0 ; n3dR = 0 ;
1013 n2dI = 0 ; n3dI = 0 ;
1014 n2dD = 0 ; n3dD = 0 ;
1015 n4d = 0 ;
1016 strcpy( tmp, p->comm_define ) ;
1017 strcpy( commuse, p->use ) ;
1018 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1019 for ( i = 0 ; i < MAX_4DARRAYS ; i++ ) strcpy(name_4d[i],"") ; /* truncate all of these */
1020 while ( t1 != NULL )
1021 {
1022 strcpy( tmp2 , t1 ) ;
1023 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
1024 { fprintf(stderr,"unparseable description for period %s\n", commname ) ; continue ; }
1025 t2 = strtok_rentr(NULL,",", &pos2) ;
1026 while ( t2 != NULL )
1027 {
1028 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1029 { fprintf(stderr,"WARNING 1 : %s in cycle spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ; }
1030 else
1031 {
1032 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
1033 { fprintf(stderr,"WARNING: only type 'real', 'doubleprecision', or 'integer' can be part of cycles exchange. %s in %s is %s\n",t2,commname,q->type->name) ; }
1034 else if ( q->boundary_array )
1035 { fprintf(stderr,"WARNING: boundary array %s cannot be member of cycles spec %s.\n",t2,commname) ; }
1036 else
1037 {
1038 if ( q->node_kind & FOURD ) {
1039 if ( n4d < MAX_4DARRAYS ) {
1040 strcpy( name_4d[n4d], q->name ) ;
1041 } else {
1042 fprintf(stderr,"REGISTRY ERROR: too many 4d arrays (> %d).\n", MAX_4DARRAYS ) ;
1043 fprintf(stderr,"That seems like a lot, but if you are sure, increase MAX_4DARRAYS\n" ) ;
1044 fprintf(stderr,"in external/RSL_LITE/gen_comms.c and recompile\n") ;
1045 exit(5) ;
1046 }
1047 n4d++ ;
1048 }
1049 else
1050 {
1051 if ( ! strcmp( q->type->name, "real") ) {
1052 if ( q->ndims == 3 ) { n3dR++ ; }
1053 else if ( q->ndims == 2 ) { n2dR++ ; }
1054 } else if ( ! strcmp( q->type->name, "integer") ) {
1055 if ( q->ndims == 3 ) { n3dI++ ; }
1056 else if ( q->ndims == 2 ) { n2dI++ ; }
1057 } else if ( ! strcmp( q->type->name, "doubleprecision") ) {
1058 if ( q->ndims == 3 ) { n3dD++ ; }
1059 else if ( q->ndims == 2 ) { n2dD++ ; }
1060 }
1061 }
1062 }
1063 }
1064 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1065 }
1066 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1067 }
1068
1069 fprintf(fp,"IF ( config_flags%%cycle_%c ) THEN\n",(xy==1)?'x':'y') ;
1070
1071 /* generate the init statement for X swap */
1072 fprintf(fp,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy, inout ) ;
1073 if ( n4d > 0 ) {
1074 fprintf(fp, " %d &\n", n3dR ) ;
1075 for ( i = 0 ; i < n4d ; i++ ) {
1076 fprintf(fp," + num_%s &\n", name_4d[i] ) ;
1077 }
1078 fprintf(fp," , %d, RWORDSIZE, &\n", n2dR ) ;
1079 } else {
1080 fprintf(fp," %d, %d, RWORDSIZE, &\n", n3dR, n2dR ) ;
1081 }
1082 fprintf(fp," %d, %d, IWORDSIZE, &\n", n3dI, n2dI ) ;
1083 fprintf(fp," %d, %d, DWORDSIZE, &\n", n3dD, n2dD ) ;
1084 fprintf(fp," 0, 0, LWORDSIZE, &\n" ) ;
1085 fprintf(fp," mytask, ntasks, ntasks_x, ntasks_y, &\n" ) ;
1086 fprintf(fp," thisdomain_max_halo_width, &\n") ;
1087 fprintf(fp," ids, ide, jds, jde, kds, kde, &\n") ;
1088 fprintf(fp," ips, ipe, jps, jpe, kps, kpe )\n") ;
1089 /* generate packs prior to stencil exchange */
1090 gen_packs( fp, p, inout, xy, 0, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
1091 /* generate stencil exchange in X */
1092 fprintf(fp," CALL RSL_LITE_CYCLE ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y )\n") ;
1093 /* generate unpacks after stencil exchange */
1094 gen_packs( fp, p, inout, xy, 1, "RSL_LITE_PACK_CYCLE", "local_communicator" ) ;
1095
1096 fprintf(fp,"END IF\n") ;
1097
1098 }
1099 close_the_file(fp) ;
1100 }
1101 return(0) ;
1102 }
1103
1104 int
1105 gen_xposes ( char * dirname )
1106 {
1107 node_t * p, * q ;
1108 char commname[NAMELEN] ;
1109 char fname[NAMELEN] ;
1110 char tmp[4096], tmp2[4096], tmp3[4096] ;
1111 char commuse[4096] ;
1112 FILE * fp ;
1113 char * t1, * t2 ;
1114 char * pos1 , * pos2 ;
1115 char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
1116 char ** x ;
1117 char post[NAMELEN], varname[NAMELEN], memord[10] ;
1118 char indices_z[NAMELEN], varref_z[NAMELEN] ;
1119 char indices_x[NAMELEN], varref_x[NAMELEN] ;
1120 char indices_y[NAMELEN], varref_y[NAMELEN] ;
1121
1122 if ( dirname == NULL ) return(1) ;
1123
1124 for ( p = Xposes ; p != NULL ; p = p->next )
1125 {
1126 for ( x = xposedir ; *x ; x++ )
1127 {
1128 strcpy( commname, p->name ) ;
1129 make_upper_case(commname) ;
1130 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
1131 else { sprintf(fname,"%s_%s.inc",commname,*x) ; }
1132 if ((fp = fopen( fname , "w" )) == NULL )
1133 {
1134 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
1135 continue ;
1136 }
1137
1138 print_warning(fp,fname) ;
1139
1140 strcpy( tmp, p->comm_define ) ;
1141 strcpy( commuse, p->use ) ;
1142 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
1143 while ( t1 != NULL )
1144 {
1145 strcpy( tmp2 , t1 ) ;
1146
1147 /* Z array */
1148 t2 = strtok_rentr(tmp2,",", &pos2) ;
1149 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1150 { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
1151 strcpy( varref_z, t2 ) ;
1152 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1153 sprintf(varref_z,"grid%%%s",t2) ;
1154 }
1155 if ( q->proc_orient != ALL_Z_ON_PROC )
1156 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
1157 if ( q->ndims != 3 )
1158 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1159 if ( q->boundary_array )
1160 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1161 strcpy (indices_z,"");
1162 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
1163 {
1164 sprintf(post,")") ;
1165 sprintf(indices_z, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
1166 }
1167 if ( q->node_kind & FOURD ) {
1168 strcat( varref_z, "(grid%sm31,grid%sm32,grid%sm33,itrace )" ) ;
1169 }
1170
1171 /* X array */
1172 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1173 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1174 { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
1175 strcpy( varref_x, t2 ) ;
1176 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1177 sprintf(varref_x,"grid%%%s",t2) ;
1178 }
1179 if ( q->proc_orient != ALL_X_ON_PROC )
1180 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
1181 if ( q->ndims != 3 )
1182 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1183 if ( q->boundary_array )
1184 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1185 strcpy (indices_x,"");
1186 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
1187 {
1188 sprintf(post,")") ;
1189 sprintf(indices_x, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
1190 }
1191 if ( q->node_kind & FOURD ) {
1192 strcat( varref_x, "(grid%sm31x,grid%sm32x,grid%sm33x,itrace )" ) ;
1193 }
1194
1195 /* Y array */
1196 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
1197 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
1198 { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
1199 strcpy( varref_y, t2 ) ;
1200 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
1201 sprintf(varref_y,"grid%%%s",t2) ;
1202 }
1203 if ( q->proc_orient != ALL_Y_ON_PROC )
1204 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
1205 if ( q->ndims != 3 )
1206 { fprintf(stderr,"WARNING: array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1207 if ( q->boundary_array )
1208 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
1209 strcpy (indices_y,"");
1210 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
1211 {
1212 sprintf(post,")") ;
1213 sprintf(indices_y, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
1214 }
1215 if ( q->node_kind & FOURD ) {
1216 strcat( varref_y, "(grid%sm31y,grid%sm32y,grid%sm33y,itrace )" ) ;
1217 }
1218
1219 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
1220 }
1221 set_mem_order( q, memord , NAMELEN) ;
1222 if ( !strcmp( *x , "z2x" ) ) {
1223 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1224 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
1225 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1226 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
1227 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
1228 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1229 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1230 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n" ) ;
1231 } else if ( !strcmp( *x , "x2z" ) ) {
1232 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1233 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
1234 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1235 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
1236 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
1237 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1238 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1239 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x ) \n" ) ;
1240 } else if ( !strcmp( *x , "x2y" ) ) {
1241 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1242 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1243 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1244 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1245 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
1246 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
1247 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
1248 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
1249 } else if ( !strcmp( *x , "y2x" ) ) {
1250 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1251 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1252 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1253 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1254 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
1255 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
1256 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
1257 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
1258 } else if ( !strcmp( *x , "y2z" ) ) {
1259 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1260 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1261 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1262 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1263 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
1264 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
1265 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
1266 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
1267 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 0, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1268 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
1269 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1270 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
1271 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
1272 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1273 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1274 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x)\n" ) ;
1275 } else if ( !strcmp( *x , "z2y" ) ) {
1276 fprintf(fp," call trans_z2x ( ntasks_x, local_communicator_x, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1277 fprintf(fp," %s, & ! variable in Z decomp\n" , varref_z ) ;
1278 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1279 fprintf(fp," grid%%sp31, grid%%ep31, grid%%sp32, grid%%ep32, grid%%sp33, grid%%ep33, &\n" ) ;
1280 fprintf(fp," grid%%sm31, grid%%em31, grid%%sm32, grid%%em32, grid%%sm33, grid%%em33, &\n" ) ;
1281 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1282 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1283 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x )\n" ) ;
1284 fprintf(fp," call trans_x2y ( ntasks_y, local_communicator_y, 1, RWORDSIZE, IWORDSIZE, DATA_ORDER_%s , &\n", memord ) ;
1285 fprintf(fp," %s, & ! variable in X decomp\n" , varref_x ) ;
1286 fprintf(fp," grid%%sd31, grid%%ed31, grid%%sd32, grid%%ed32, grid%%sd33, grid%%ed33, &\n" ) ;
1287 fprintf(fp," grid%%sp31x, grid%%ep31x, grid%%sp32x, grid%%ep32x, grid%%sp33x, grid%%ep33x, &\n" ) ;
1288 fprintf(fp," grid%%sm31x, grid%%em31x, grid%%sm32x, grid%%em32x, grid%%sm33x, grid%%em33x, &\n" ) ;
1289 fprintf(fp," %s, & ! variable in Y decomp\n" , varref_y ) ;
1290 fprintf(fp," grid%%sp31y, grid%%ep31y, grid%%sp32y, grid%%ep32y, grid%%sp33y, grid%%ep33y, &\n" ) ;
1291 fprintf(fp," grid%%sm31y, grid%%em31y, grid%%sm32y, grid%%em32y, grid%%sm33y, grid%%em33y ) \n" ) ;
1292 }
1293
1294 close_the_file(fp) ;
1295 }
1296 skiperific:
1297 ;
1298 }
1299 return(0) ;
1300 }
1301
1302 int
1303 gen_comm_descrips ( char * dirname )
1304 {
1305 node_t * p ;
1306 char * fn = "dm_comm_cpp_flags" ;
1307 char commname[NAMELEN] ;
1308 char fname[NAMELEN] ;
1309 FILE * fp ;
1310 int ncomm ;
1311
1312 if ( dirname == NULL ) return(1) ;
1313
1314 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
1315 else { sprintf(fname,"%s",fn) ; }
1316
1317 if ((fp = fopen( fname , "w" )) == NULL )
1318 {
1319 fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
1320 }
1321
1322 return(0) ;
1323 }
1324
1325
1326
1327 int
1328 gen_shift ( char * dirname )
1329 {
1330 int i ;
1331 FILE * fp ;
1332 node_t *p, *q, *dimd ;
1333 char **direction ;
1334 char *directions[] = { "x", "y", 0L } ;
1335 char fname[NAMELEN], vname[NAMELEN] ;
1336 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
1337 char memord[NAMELEN] ;
1338 int xdex,ydex,zdex ;
1339 node_t Shift ;
1340 int said_it = 0 ;
1341 int said_it2 = 0 ;
1342
1343 for ( direction = directions ; *direction != NULL ; direction++ )
1344 {
1345 if ( dirname == NULL ) return(1) ;
1346 sprintf(fname,"shift_halo_%s_halo",*direction) ;
1347
1348 Shift.next = NULL ;
1349 sprintf( Shift.use, "" ) ;
1350 strcpy( Shift.comm_define, "48:" ) ;
1351 strcpy( Shift.name , fname ) ;
1352 for ( p = Domain.fields ; p != NULL ; p = p->next ) {
1353 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
1354 {
1355
1356 /* special cases in WRF */
1357 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
1358 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
1359 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
1360 if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
1361 fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
1362 fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
1363 said_it = 1 ; }
1364 continue ;
1365 }
1366
1367 /* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
1368 /* also make sure we don't shift or halo any transpose variables (ALL_X_ON_PROC or ALL_Y_ON_PROC) */
1369 if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) &&
1370 !(p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC) ) {
1371
1372 if ( p->subgrid != 0 ) { /* moving nests not implemented for subgrid variables */
1373 if ( sw_move && ! said_it2 ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for subgrid variables \n") ;
1374 said_it2 = 1 ; }
1375 continue ;
1376 }
1377 if ( p->type->type_type == SIMPLE )
1378 {
1379 for ( i = 1 ; i <= p->ntl ; i++ )
1380 {
1381 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
1382 else sprintf(vname,"%s",p->name ) ;
1383 strcat( Shift.comm_define, vname ) ;
1384 strcat( Shift.comm_define, "," ) ;
1385 }
1386 }
1387 }
1388 }
1389 }
1390 if ( strlen(Shift.comm_define) > 0 )Shift.comm_define[strlen(Shift.comm_define)-1] = '\0' ;
1391
1392 gen_halos( dirname , NULL, &Shift ) ;
1393
1394 sprintf(fname,"%s/shift_halo_%s.inc",dirname,*direction) ;
1395 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1396
1397 /* now generate the shifts themselves */
1398 for ( p = Domain.fields ; p != NULL ; p = p->next )
1399 {
1400
1401 /* special cases in WRF */
1402 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
1403 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
1404 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
1405 continue ;
1406 }
1407 /* do not shift transpose variables */
1408 if ( p->proc_orient == ALL_X_ON_PROC || p->proc_orient == ALL_Y_ON_PROC ) continue ;
1409
1410 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
1411 {
1412
1413 if ( p->type->type_type == SIMPLE )
1414 {
1415 for ( i = 1 ; i <= p->ntl ; i++ )
1416 {
1417
1418 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
1419 else sprintf(vname,"%s",p->name ) ;
1420
1421 if ( p->node_kind & FOURD )
1422 {
1423 node_t *member ;
1424
1425 xdex = get_index_for_coord( p , COORD_X ) ;
1426 ydex = get_index_for_coord( p , COORD_Y ) ;
1427 zdex = get_index_for_coord( p , COORD_Z ) ;
1428 if ( zdex >=1 && zdex <= 3 )
1429 {
1430 set_mem_order( p->members, memord , NAMELEN) ;
1431 fprintf(fp, " DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
1432 if ( !strcmp( *direction, "x" ) )
1433 {
1434 char * stag = "" ;
1435 stag = p->members->stag_x?"":"-1" ;
1436 if ( !strcmp( memord , "XYZ" ) ) {
1437 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1438 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:,itrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:,itrace)\n", vname, stag, vname, stag ) ;
1439 fprintf(fp,"ENDIF\n") ;
1440 } else if ( !strcmp( memord , "YXZ" ) ) {
1441 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1442 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:,itrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:,itrace)\n", vname, stag, vname, stag ) ;
1443 fprintf(fp,"ENDIF\n") ;
1444 } else if ( !strcmp( memord , "XZY" ) ) {
1445 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1446 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme,itrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme,itrace)\n", vname, stag, vname, stag ) ;
1447 fprintf(fp,"ENDIF\n") ;
1448 } else if ( !strcmp( memord , "YZX" ) ) {
1449 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1450 fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe),itrace) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px,itrace)\n", vname, stag, vname, stag ) ;
1451 fprintf(fp,"ENDIF\n") ;
1452 } else if ( !strcmp( memord , "ZXY" ) ) {
1453 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1454 fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme,itrace) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme,itrace)\n", vname, stag, vname, stag ) ;
1455 fprintf(fp,"ENDIF\n") ;
1456 } else if ( !strcmp( memord , "ZYX" ) ) {
1457 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1458 fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe),itrace) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px,itrace)\n", vname, stag, vname, stag ) ;
1459 fprintf(fp,"ENDIF\n") ;
1460 } else if ( !strcmp( memord , "XY" ) ) {
1461 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1462 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,itrace) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,itrace)\n", vname, stag, vname, stag ) ;
1463 fprintf(fp,"ENDIF\n") ;
1464 } else if ( !strcmp( memord , "YX" ) ) {
1465 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1466 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),itrace) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,itrace)\n", vname, stag, vname, stag ) ;
1467 fprintf(fp,"ENDIF\n") ;
1468 }
1469 }
1470 else
1471 {
1472 char * stag = "" ;
1473 stag = p->members->stag_y?"":"-1" ;
1474 if ( !strcmp( memord , "XYZ" ) ) {
1475 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1476 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:,itrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:,itrace)\n", vname, stag, vname, stag ) ;
1477 fprintf(fp,"ENDIF\n") ;
1478 } else if ( !strcmp( memord , "YXZ" ) ) {
1479 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1480 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:,itrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:,itrace)\n", vname, stag, vname, stag ) ;
1481 fprintf(fp,"ENDIF\n") ;
1482 } else if ( !strcmp( memord , "XZY" ) ) {
1483 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1484 fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe),itrace) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py,itrace)\n", vname, stag, vname, stag ) ;
1485 fprintf(fp,"ENDIF\n") ;
1486 } else if ( !strcmp( memord , "YZX" ) ) {
1487 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1488 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime,itrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime,itrace)\n", vname, stag, vname, stag ) ;
1489 fprintf(fp,"ENDIF\n") ;
1490 } else if ( !strcmp( memord , "ZXY" ) ) {
1491 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1492 fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe),itrace) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py,itrace)\n", vname, stag, vname, stag ) ;
1493 fprintf(fp,"ENDIF\n") ;
1494 } else if ( !strcmp( memord , "ZYX" ) ) {
1495 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1496 fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime,itrace) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime,itrace)\n", vname, stag, vname, stag ) ;
1497 fprintf(fp,"ENDIF\n") ;
1498 } else if ( !strcmp( memord , "XY" ) ) {
1499 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1500 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),itrace) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,itrace)\n", vname, stag, vname, stag ) ;
1501 fprintf(fp,"ENDIF\n") ;
1502 } else if ( !strcmp( memord , "YX" ) ) {
1503 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1504 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,itrace) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,itrace)\n", vname, stag, vname, stag ) ;
1505 fprintf(fp,"ENDIF\n") ;
1506 }
1507 }
1508 fprintf(fp, " ENDDO\n" ) ;
1509 }
1510 else
1511 {
1512 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
1513 }
1514 }
1515 else
1516 {
1517 xdex = get_index_for_coord( p , COORD_X ) ;
1518 ydex = get_index_for_coord( p , COORD_Y ) ;
1519 set_mem_order( p, memord , NAMELEN) ;
1520 if ( !strcmp( *direction, "x" ) ) {
1521 if ( !strcmp( memord , "XYZ" ) ) {
1522 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1523 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme,:) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme,:)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1524 fprintf(fp,"ENDIF\n") ;
1525 } else if ( !strcmp( memord , "YXZ" ) ) {
1526 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1527 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe),:) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px,:)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1528 fprintf(fp,"ENDIF\n") ;
1529 } else if ( !strcmp( memord , "XZY" ) ) {
1530 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1531 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),:,jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,:,jms:jme)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1532 fprintf(fp,"ENDIF\n") ;
1533 } else if ( !strcmp( memord , "YZX" ) ) {
1534 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1535 fprintf(fp,"grid%%%s (jms:jme,:,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,:,ips+px:min(ide%s,ipe)+px)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1536 fprintf(fp,"ENDIF\n") ;
1537 } else if ( !strcmp( memord , "ZXY" ) ) {
1538 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1539 fprintf(fp,"grid%%%s (:,ips:min(ide%s,ipe),jms:jme) = grid%%%s (:,ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1540 fprintf(fp,"ENDIF\n") ;
1541 } else if ( !strcmp( memord , "ZYX" ) ) {
1542 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1543 fprintf(fp,"grid%%%s (:,jms:jme,ips:min(ide%s,ipe)) = grid%%%s (:,jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1544 fprintf(fp,"ENDIF\n") ;
1545 } else if ( !strcmp( memord , "XY" ) ) {
1546 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1547 fprintf(fp,"grid%%%s (ips:min(ide%s,ipe),jms:jme) = grid%%%s (ips+px:min(ide%s,ipe)+px,jms:jme)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1548 fprintf(fp,"ENDIF\n") ;
1549 } else if ( !strcmp( memord , "YX" ) ) {
1550 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1551 fprintf(fp,"grid%%%s (jms:jme,ips:min(ide%s,ipe)) = grid%%%s (jms:jme,ips+px:min(ide%s,ipe)+px)\n", vname, p->stag_x?"":"-1", vname, p->stag_x?"":"-1" ) ;
1552 fprintf(fp,"ENDIF\n") ;
1553 }
1554 } else {
1555 if ( !strcmp( memord , "XYZ" ) ) {
1556 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1557 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe),:) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1558 fprintf(fp,"ENDIF\n") ;
1559 } else if ( !strcmp( memord , "YXZ" ) ) {
1560 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1561 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime,:) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime,:)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1562 fprintf(fp,"ENDIF\n") ;
1563 } else if ( !strcmp( memord , "XZY" ) ) {
1564 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1565 fprintf(fp,"grid%%%s (ims:ime,:,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,:,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1566 fprintf(fp,"ENDIF\n") ;
1567 } else if ( !strcmp( memord , "YZX" ) ) {
1568 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1569 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),:,ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,:,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1570 fprintf(fp,"ENDIF\n") ;
1571 } else if ( !strcmp( memord , "ZXY" ) ) {
1572 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1573 fprintf(fp,"grid%%%s (:,ims:ime,jps:min(jde%s,jpe)) = grid%%%s (:,ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1574 fprintf(fp,"ENDIF\n") ;
1575 } else if ( !strcmp( memord , "ZYX" ) ) {
1576 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1577 fprintf(fp,"grid%%%s (:,jps:min(jde%s,jpe),ims:ime) = grid%%%s (:,jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1578 fprintf(fp,"ENDIF\n") ;
1579 } else if ( !strcmp( memord , "XY" ) ) {
1580 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1581 fprintf(fp,"grid%%%s (ims:ime,jps:min(jde%s,jpe)) = grid%%%s (ims:ime,jps+py:min(jde%s,jpe)+py)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1582 fprintf(fp,"ENDIF\n") ;
1583 } else if ( !strcmp( memord , "YX" ) ) {
1584 fprintf(fp,"IF ( SIZE(grid%%%s,%d)*SIZE(grid%%%s,%d) .GT. 1 ) THEN\n",vname,xdex+1,vname,ydex+1) ;
1585 fprintf(fp,"grid%%%s (jps:min(jde%s,jpe),ims:ime) = grid%%%s (jps+py:min(jde%s,jpe)+py,ims:ime)\n", vname, p->stag_y?"":"-1", vname, p->stag_y?"":"-1" ) ;
1586 fprintf(fp,"ENDIF\n") ;
1587 }
1588 }
1589 }
1590 }
1591 }
1592 }
1593 }
1594 close_the_file(fp) ;
1595 }
1596 }
1597
1598 int
1599 gen_datacalls ( char * dirname )
1600 {
1601 FILE * fp ;
1602 char * fn = "data_calls.inc" ;
1603 char fname[NAMELEN] ;
1604
1605 if ( dirname == NULL ) return(1) ;
1606 if ( strlen(dirname) > 0 )
1607 { sprintf(fname,"%s/%s",dirname,fn) ; }
1608 else
1609 { sprintf(fname,"%s",fn) ; }
1610 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1611 print_warning(fp,fname) ;
1612 close_the_file(fp) ;
1613 return(0) ;
1614 }
1615
1616 /*****************/
1617 /*****************/
1618
1619 gen_nest_packing ( char * dirname )
1620 {
1621 gen_nest_pack( dirname ) ;
1622 gen_nest_unpack( dirname ) ;
1623 }
1624
1625 #define PACKIT 1
1626 #define UNPACKIT 2
1627
1628 int
1629 gen_nest_pack ( char * dirname )
1630 {
1631 int i ;
1632 FILE * fp ;
1633 char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
1634 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
1635 int ipath ;
1636 char ** fnp ; char * fn ;
1637 char * shw_str ;
1638 char fname[NAMELEN] ;
1639 node_t *node, *p, *dim ;
1640 int xdex, ydex, zdex ;
1641 char ddim[3][2][NAMELEN] ;
1642 char mdim[3][2][NAMELEN] ;
1643 char pdim[3][2][NAMELEN] ;
1644 char vname[NAMELEN] ; char tag[NAMELEN] ;
1645 int d2, d3, sw ;
1646 char *info_name ;
1647
1648 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
1649 {
1650 fn = *fnp ;
1651 if ( dirname == NULL ) return(1) ;
1652 if ( strlen(dirname) > 0 ) {
1653 sprintf(fname,"%s/%s",dirname,fn) ;
1654 } else {
1655 sprintf(fname,"%s",fn) ;
1656 }
1657 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1658 print_warning(fp,fname) ;
1659
1660 d2 = 0 ;
1661 d3 = 0 ;
1662 node = Domain.fields ;
1663
1664 count_fields ( node , &d2 , &d3 , down_path[ipath] ) ;
1665
1666 if ( d2 + d3 > 0 ) {
1667 if ( down_path[ipath] == INTERP_UP )
1668 {
1669 info_name = "rsl_lite_to_parent_info" ;
1670 sw = 0 ;
1671 }
1672 else
1673 {
1674 info_name = "rsl_lite_to_child_info" ;
1675 sw = 1 ;
1676 }
1677
1678 fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
1679
1680 fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ;
1681 fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ;
1682 if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ;
1683 fprintf(fp," ,nids,nide,njds,njde &\n") ;
1684 if (sw) fprintf(fp," ,pgr , sw &\n") ;
1685 fprintf(fp," ,ntasks_x,ntasks_y &\n") ;
1686 fprintf(fp," ,thisdomain_max_halo_width &\n") ;
1687 fprintf(fp," ,icoord,jcoord &\n") ;
1688 fprintf(fp," ,idim_cd,jdim_cd &\n") ;
1689 fprintf(fp," ,pig,pjg,retval )\n") ;
1690
1691 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1692
1693 gen_nest_packunpack ( fp , Domain.fields, PACKIT, down_path[ipath] ) ;
1694
1695 fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ;
1696 fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ;
1697 if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ;
1698 fprintf(fp," ,nids,nide,njds,njde &\n") ;
1699 if (sw) fprintf(fp," ,pgr , sw &\n") ;
1700 fprintf(fp," ,ntasks_x,ntasks_y &\n") ;
1701 fprintf(fp," ,thisdomain_max_halo_width &\n") ;
1702 fprintf(fp," ,icoord,jcoord &\n") ;
1703 fprintf(fp," ,idim_cd,jdim_cd &\n") ;
1704 fprintf(fp," ,pig,pjg,retval )\n") ;
1705
1706 fprintf(fp,"ENDDO\n") ;
1707 }
1708 close_the_file(fp) ;
1709 }
1710 return(0) ;
1711 }
1712
1713 int
1714 gen_nest_unpack ( char * dirname )
1715 {
1716 int i ;
1717 FILE * fp ;
1718 char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
1719 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
1720 int ipath ;
1721 char ** fnp ; char * fn ;
1722 char fname[NAMELEN] ;
1723 node_t *node, *p, *dim ;
1724 int xdex, ydex, zdex ;
1725 char ddim[3][2][NAMELEN] ;
1726 char mdim[3][2][NAMELEN] ;
1727 char pdim[3][2][NAMELEN] ;
1728 char *info_name ;
1729 char vname[NAMELEN] ; char tag[NAMELEN] ;
1730 int d2, d3 ;
1731
1732 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
1733 {
1734 fn = *fnp ;
1735 d2 = 0 ;
1736 d3 = 0 ;
1737 node = Domain.fields ;
1738
1739 if ( dirname == NULL ) return(1) ;
1740 if ( strlen(dirname) > 0 )
1741 { sprintf(fname,"%s/%s",dirname,fn) ; }
1742 else
1743 { sprintf(fname,"%s",fn) ; }
1744 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1745 print_warning(fp,fname) ;
1746
1747 count_fields ( node , &d2 , &d3 , down_path[ipath] ) ;
1748
1749 if ( d2 + d3 > 0 ) {
1750 if ( down_path[ipath] == INTERP_UP )
1751 {
1752 info_name = "rsl_lite_from_child_info" ;
1753 }
1754 else
1755 {
1756 info_name = "rsl_lite_from_parent_info" ;
1757 }
1758
1759 fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
1760 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1761 gen_nest_packunpack ( fp , Domain.fields, UNPACKIT, down_path[ipath] ) ;
1762 fprintf(fp,"CALL %s(pig,pjg,retval)\n", info_name ) ;
1763 fprintf(fp,"ENDDO\n") ;
1764 }
1765 close_the_file(fp) ;
1766 }
1767 return(0) ;
1768 }
1769
1770 int
1771 gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path )
1772 {
1773 int i ;
1774 node_t *p, *p1, *dim ;
1775 int d2, d3, xdex, ydex, zdex ;
1776 int io_mask ;
1777 char * grid ;
1778 char ddim[3][2][NAMELEN] ;
1779 char mdim[3][2][NAMELEN] ;
1780 char pdim[3][2][NAMELEN] ;
1781 char vname[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ;
1782 char c, d ;
1783
1784 for ( p1 = node ; p1 != NULL ; p1 = p1->next )
1785 {
1786
1787 if ( p1->node_kind & FOURD )
1788 {
1789 if ( p1->members->next )
1790 io_mask = p1->members->next->io_mask ;
1791 else
1792 continue ;
1793 }
1794 else
1795 {
1796 io_mask = p1->io_mask ;
1797 }
1798 p = p1 ;
1799
1800 if ( io_mask & down_path )
1801 {
1802 if ( p->node_kind & FOURD ) {
1803 if ( p->members->next->ntl > 1 ) sprintf(tag,"_2") ;
1804 else sprintf(tag,"") ;
1805 set_dim_strs ( p->members , ddim , mdim , pdim , "c", 0 ) ;
1806 zdex = get_index_for_coord( p->members , COORD_Z ) ;
1807 xdex = get_index_for_coord( p->members , COORD_X ) ;
1808 ydex = get_index_for_coord( p->members , COORD_Y ) ;
1809 } else {
1810 if ( p->ntl > 1 ) sprintf(tag,"_2") ;
1811 else sprintf(tag,"") ;
1812 set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
1813 zdex = get_index_for_coord( p , COORD_Z ) ;
1814 xdex = get_index_for_coord( p , COORD_X ) ;
1815 ydex = get_index_for_coord( p , COORD_Y ) ;
1816 }
1817
1818 if ( down_path == INTERP_UP )
1819 {
1820 c = ( dir == PACKIT )?'n':'p' ;
1821 d = ( dir == PACKIT )?'2':'1' ;
1822 } else {
1823 c = ( dir == UNPACKIT )?'n':'p' ;
1824 d = ( dir == UNPACKIT )?'2':'1' ;
1825 }
1826
1827 if ( zdex >= 0 ) {
1828 if ( xdex == 0 && zdex == 1 && ydex == 2 ) sprintf(dexes,"pig,k,pjg") ;
1829 else if ( zdex == 0 && xdex == 1 && ydex == 2 ) sprintf(dexes,"k,pig,pjg") ;
1830 else if ( xdex == 0 && ydex == 1 && zdex == 2 ) sprintf(dexes,"pig,pjg,k") ;
1831 } else {
1832 if ( xdex == 0 && ydex == 1 ) sprintf(dexes,"pig,pjg") ;
1833 if ( ydex == 0 && xdex == 1 ) sprintf(dexes,"pjg,pig") ;
1834 }
1835
1836 /* construct variable name */
1837 if ( p->node_kind & FOURD )
1838 {
1839 sprintf(vname,"%s%s(%s,itrace)",p->name,tag,dexes) ;
1840 }
1841 else
1842 {
1843 sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
1844 }
1845
1846 grid = "grid%" ;
1847 if ( p->node_kind & FOURD )
1848 {
1849 grid = "" ;
1850 fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name) ;
1851 } else {
1852 /* note that in the case if dir != UNPACKIT and down_path == INTERP_UP the data
1853 structure being used is intermediate_grid, not grid. However, intermediate_grid
1854 and grid share the same id (see module_dm.F) so it will not make a difference. */
1855 #if 0
1856 fprintf(fp,"IF ( in_use_for_config(grid%%id,'%s%s') ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",p->name,tag) ;
1857 #else
1858 fprintf(fp,"IF ( SIZE(%s%s%s) .GT. 1 ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c\n",grid,p->name,tag) ;
1859 #endif
1860 }
1861
1862 if ( dir == UNPACKIT )
1863 {
1864 if ( down_path == INTERP_UP )
1865 {
1866 char *sjl = "" ;
1867 if ( !strcmp( p->interpu_fcn_name ,"nmm_vfeedback") ) sjl = "_v" ; /* KLUDGE FOR NCEP NESTING 20071217 */
1868 if ( zdex >= 0 ) {
1869 fprintf(fp,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
1870 } else {
1871 fprintf(fp,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
1872 }
1873 fprintf(fp,"IF ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
1874 sjl ,
1875 p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
1876 if ( zdex >= 0 ) {
1877 fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], grid, vname ) ;
1878 } else {
1879 fprintf(fp,"NEST_INFLUENCE(%s%s,xv(1))\n", grid, vname ) ;
1880 }
1881 fprintf(fp,"ENDIF\n") ;
1882 }
1883 else
1884 {
1885 if ( zdex >= 0 ) {
1886 fprintf(fp,"CALL rsl_lite_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\n%s%s = xv(k)\nENDDO\n",
1887 ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], grid, vname) ;
1888 } else {
1889 fprintf(fp,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid, vname) ;
1890 }
1891 }
1892 }
1893 else
1894 {
1895 if ( down_path == INTERP_UP )
1896 {
1897 if ( zdex >= 0 ) {
1898 fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_lite_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1899 ddim[zdex][0], ddim[zdex][1], vname, ddim[zdex][1], ddim[zdex][0] ) ;
1900 } else {
1901 fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname) ;
1902 }
1903 }
1904 else
1905 {
1906 if ( zdex >= 0 ) {
1907 fprintf(fp,"DO k = %s,%s\nxv(k)= %s%s\nENDDO\nCALL rsl_lite_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1908 ddim[zdex][0], ddim[zdex][1], grid, vname, ddim[zdex][1], ddim[zdex][0] ) ;
1909 } else {
1910 fprintf(fp,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid, vname) ;
1911 }
1912 }
1913 }
1914 if ( p->node_kind & FOURD )
1915 {
1916 fprintf(fp,"ENDDO\n") ;
1917 }
1918 else
1919 {
1920 fprintf(fp,"ENDIF\n") ; /* in_use_for_config */
1921 }
1922 }
1923 }
1924
1925 return(0) ;
1926 }
1927
1928 /*****************/
1929
1930 int
1931 count_fields ( node_t * node , int * d2 , int * d3 , int down_path )
1932 {
1933 node_t * p ;
1934 int zdex ;
1935 /* count up the total number of levels from all fields */
1936 for ( p = node ; p != NULL ; p = p->next )
1937 {
1938 if ( p->node_kind == FOURD )
1939 {
1940 count_fields( p->members , d2 , d3 , down_path ) ; /* RECURSE */
1941 }
1942 else
1943 {
1944 if ( p->io_mask & down_path )
1945 {
1946 if ( p->node_kind == FOURD )
1947 zdex = get_index_for_coord( p->members , COORD_Z ) ;
1948 else
1949 zdex = get_index_for_coord( p , COORD_Z ) ;
1950
1951 if ( zdex < 0 ) {
1952 (*d2)++ ; /* if no zdex then only 2 d */
1953 } else {
1954 (*d3)++ ; /* if has a zdex then 3 d */
1955 }
1956 }
1957 }
1958 }
1959 return(0) ;
1960 }
1961
1962 /*****************/
1963 /*****************/
1964
1965 int
1966 gen_debug ( char * dirname )
1967 {
1968 int i ;
1969 FILE * fp ;
1970 node_t *p, *q, *dimd ;
1971 char **direction ;
1972 char *directions[] = { "x", "y", 0L } ;
1973 char fname[NAMELEN], vname[NAMELEN] ;
1974 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
1975 int zdex ;
1976 node_t Shift ;
1977 int said_it = 0 ;
1978 int said_it2 = 0 ;
1979
1980 if ( dirname == NULL ) return(1) ;
1981
1982 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/debuggal.inc",dirname) ; }
1983 else { sprintf(fname,"debuggal.inc") ; }
1984 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1985
1986 /* now generate the shifts themselves */
1987 for ( p = Domain.fields ; p != NULL ; p = p->next )
1988 {
1989
1990 /* special cases in WRF */
1991 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
1992 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
1993 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
1994 continue ;
1995 }
1996
1997 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array )
1998 {
1999
2000 if ( p->type->type_type == SIMPLE )
2001 {
2002 for ( i = 1 ; i <= p->ntl ; i++ )
2003 {
2004
2005 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
2006 else sprintf(vname,"%s",p->name ) ;
2007
2008 if ( p->node_kind & FOURD )
2009 {
2010 #if 0
2011 node_t *member ;
2012 zdex = get_index_for_coord( p , COORD_Z ) ;
2013 if ( zdex >=1 && zdex <= 3 && strncmp(vname,"fdda",4) )
2014 {
2015 fprintf(fp, " DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p->name ) ;
2016 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', itrace , %s ( IDEBUG,KDEBUG,JDEBUG,itrace)\n", vname, vname ) ;
2017 fprintf(fp, " ENDDO\n" ) ;
2018 }
2019 else
2020 {
2021 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
2022 }
2023 #endif
2024 }
2025 else
2026 {
2027 if ( p->ndims == 3 ) {
2028 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,KDEBUG,JDEBUG)\n", vname, vname ) ;
2029 } else if ( p->ndims == 2 ) {
2030 fprintf(fp, " write(0,*) AAA_AAA,BBB_BBB, '%s ', grid%%%s ( IDEBUG,JDEBUG)\n", vname, vname ) ;
2031 }
2032 }
2033 }
2034 }
2035 }
2036 }
2037
2038 close_the_file(fp) ;
2039 }
2040
2041 /*****************/
2042 /*****************/
2043
2044 int
2045 gen_comms ( char * dirname )
2046 {
2047 FILE *fpsub ;
2048 if ( sw_dm_parallel )
2049 fprintf(stderr,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
2050
2051 /* truncate this file if it exists */
2052 if ((fpsub = fopen( "inc/REGISTRY_COMM_DM_subs.inc" , "w" )) != NULL ) fclose(fpsub) ;
2053
2054 gen_halos( "inc" , NULL, Halos ) ;
2055 gen_shift( "inc" ) ;
2056 gen_periods( "inc", Periods ) ;
2057 gen_swaps( "inc", Swaps ) ;
2058 gen_cycles( "inc", Cycles ) ;
2059 gen_xposes( "inc" ) ;
2060 gen_comm_descrips( "inc" ) ;
2061 gen_datacalls( "inc" ) ;
2062 gen_nest_packing( "inc" ) ;
2063 #if 0
2064 gen_debug( "inc" ) ;
2065 #endif
2066
2067 return(0) ;
2068 }
2069
A coupled weather-fire forecasting model built on top of Weather Research and Forecasting (WRF).