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