?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
added README_changes.txt
[wrffire.git] / wrfv2_fire / external / RSL / gen_comms.c
blobb4ecff6f5c63ef65efa77be27d9b9b6101913ea9
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 int
14 gen_halos ( char * dirname )
15 {
16 node_t * p, * q ;
17 node_t * dimd ;
18 char commname[NAMELEN] ;
19 char fname[NAMELEN] ;
20 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
21 char commuse[NAMELEN_LONG] ;
22 int maxstenwidth, stenwidth ;
23 FILE * fp ;
24 char * t1, * t2 ;
25 char * pos1 , * pos2 ;
26 char indices[NAMELEN], post[NAMELEN], varref[NAMELEN] ;
27 int zdex ;
28
29 if ( dirname == NULL ) return(1) ;
30
31 for ( p = Halos ; p != NULL ; p = p->next )
32 {
33 strcpy( commname, p->name ) ;
34 make_upper_case(commname) ;
35 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
36 else { sprintf(fname,"%s.inc",commname) ; }
37 if ((fp = fopen( fname , "w" )) == NULL )
38 {
39 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
40 continue ;
41 }
42 /* get maximum stencil width */
43 maxstenwidth = 0 ;
44 strcpy( tmp, p->comm_define ) ;
45 t1 = strtok_rentr( tmp , "; " , &pos1 ) ;
46 while ( t1 != NULL )
47 {
48 strcpy( tmp2 , t1 ) ;
49 if (( t2 = strtok_rentr( tmp2 , ": " , &pos2 )) == NULL )
50 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
51 stenwidth = atoi (t2) ;
52 if ( stenwidth == 0 )
53 { fprintf(stderr,"* unparseable description for halo %s\n", commname ) ; exit(1) ; }
54 if ( stenwidth > maxstenwidth ) maxstenwidth = stenwidth ;
55 t1 = strtok_rentr( NULL , "; " , &pos1 ) ;
56 }
57 print_warning(fp,fname) ;
58 fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
59 fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
60 fprintf(fp," BECAUSE IT CONTAINS AN RSL HALO OPERATION\n" ) ;
61 fprintf(fp,"#endif\n") ;
62
63 fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value ) THEN\n",commname ) ;
64 fprintf(fp," CALL wrf_debug ( 50 , 'set up halo %s' )\n",commname ) ;
65 fprintf(fp," CALL setup_halo_rsl( grid )\n" ) ;
66 fprintf(fp," CALL reset_msgs_%dpt\n", maxstenwidth ) ;
67
68 /* pass through description again now and generate the calls */
69 strcpy( tmp, p->comm_define ) ;
70 strcpy( commuse, p->use ) ;
71 t1 = strtok_rentr( tmp , "; " , &pos1 ) ;
72 while ( t1 != NULL )
73 {
74 strcpy( tmp2 , t1 ) ;
75 if (( t2 = strtok_rentr( tmp2 , ": " , &pos2 )) == NULL )
76 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; continue ; }
77 stenwidth = atoi (t2) ;
78 t2 = strtok_rentr(NULL,", ", &pos2) ;
79
80 while ( t2 != NULL )
81 {
82 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
83 {
84 fprintf(stderr,"WARNING 1 : %s in halo spec %s (%s) is not defined in registry.\n",t2,commname, commuse) ;
85 }
86 else
87 {
88
89 strcpy( varref, t2 ) ;
90 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
91 if ( !strncmp( q->use, "dyn_", 4 )) {
92 char * core ;
93 core = q->use+4 ;
94 sprintf(varref,"grid%%%s_%s",core,t2) ;
95 } else {
96 sprintf(varref,"grid%%%s",t2) ;
97 }
98 }
99
100 if ( strcmp( q->type->name, "real") && strcmp( q->type->name, "integer") && strcmp( q->type->name, "doubleprecision") )
101 {
102 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) ;
103 }
104 else if ( q->boundary_array )
105 {
106 fprintf(stderr,"WARNING: boundary array %s cannot be member of halo spec %s.\n",t2,commname) ;
107 }
108 else
109 {
110 if ( q->node_kind & FOURD )
111 {
112 node_t *member ;
113 zdex = get_index_for_coord( q , COORD_Z ) ;
114 if ( zdex >=1 && zdex <= 3 )
115 {
116 for ( member = q->members ; member != NULL ; member = member->next )
117 {
118 if ( strcmp( member->name, "-" ) )
119 {
120 fprintf(fp," if ( P_%s .GT. 1 ) CALL add_msg_%dpt_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
121 member->name, stenwidth, q->type->name, t2 , member->name, zdex+1 ) ;
122 }
123 }
124 }
125 else
126 {
127 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
128 }
129 }
130 else
131 {
132 strcpy (indices,"");
133 if ( sw_deref_kludge ) /* && strchr (t2, '%') != NULLCHARPTR ) */
134 {
135 sprintf(post,")") ;
136 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
137 }
138 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
139 zdex = get_index_for_coord( q , COORD_Z ) ;
140 if ( dimd != NULL )
141 {
142 char dimstrg[256] ;
143
144 if ( dimd->len_defined_how == DOMAIN_STANDARD )
145 sprintf(dimstrg,"(glen(%d))",zdex+1) ;
146 else if ( dimd->len_defined_how == NAMELIST )
147 {
148 if ( !strcmp(dimd->assoc_nl_var_s,"1") )
149 sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
150 else
151 sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
152 }
153 else if ( dimd->len_defined_how == CONSTANT )
154 sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
155
156 fprintf(fp," CALL add_msg_%dpt_%s ( %s%s , %s )\n", stenwidth, q->type->name, varref, indices, dimstrg ) ;
157 }
158 else if ( q->ndims == 2 ) /* 2d */
159 {
160 fprintf(fp," CALL add_msg_%dpt_%s ( %s%s , %s )\n", stenwidth, q->type->name, varref, indices, "1" ) ;
161 }
162 }
163 }
164 q->subject_to_communication = 1 ; /* Indicate that this field may be communicated */
165 }
166 t2 = strtok_rentr( NULL , ", " , &pos2 ) ;
167 }
168 t1 = strtok_rentr( NULL , "; " , &pos1 ) ;
169 }
170 fprintf(fp," CALL stencil_%dpt ( grid%%domdesc , grid%%comms ( %s ) )\n", maxstenwidth , commname ) ;
171 fprintf(fp,"ENDIF\n") ;
172 fprintf(fp," CALL wrf_debug ( 50 , 'exchange halo %s' )\n",commname ) ;
173 fprintf(fp,"CALL rsl_exch_stencil ( grid%%domdesc , grid%%comms( %s ) )\n", commname ) ;
174
175 close_the_file(fp) ;
176 }
177 return(0) ;
178 }
179
180 int
181 gen_periods ( char * dirname )
182 {
183 node_t * p, * q ;
184 char commname[NAMELEN] ;
185 char fname[NAMELEN] ;
186 char indices[NAMELEN], post[NAMELEN], varref[NAMELEN] ;
187 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG], commuse[NAMELEN_LONG] ;
188 int maxperwidth, perwidth ;
189 FILE * fp ;
190 char * t1, * t2 ;
191 char * pos1 , * pos2 ;
192 node_t * dimd ;
193 int zdex ;
194
195 if ( dirname == NULL ) return(1) ;
196
197 for ( p = Periods ; p != NULL ; p = p->next )
198 {
199 strcpy( commname, p->name ) ;
200 make_upper_case(commname) ;
201 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s.inc",dirname,commname) ; }
202 else { sprintf(fname,"%s.inc",commname) ; }
203 if ((fp = fopen( fname , "w" )) == NULL )
204 {
205 fprintf(stderr,"WARNING: gen_periods in registry cannot open %s for writing\n",fname ) ;
206 continue ;
207 }
208 /* get maximum stencil width */
209 maxperwidth = 0 ;
210 strcpy( tmp, p->comm_define ) ;
211 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
212 while ( t1 != NULL )
213 {
214 strcpy( tmp2 , t1 ) ;
215 if (( t2 = strtok_rentr( tmp2 , ":" , &pos2 )) == NULL )
216 { fprintf(stderr,"unparseable description for halo %s\n", commname ) ; exit(1) ; }
217 perwidth = atoi (t2) ;
218 if ( perwidth > maxperwidth ) maxperwidth = perwidth ;
219 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
220 }
221 print_warning(fp,fname) ;
222
223 fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
224 fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
225 fprintf(fp," BECAUSE IT CONTAINS AN RSL PERIOD OPERATION\n" ) ;
226 fprintf(fp,"#endif\n") ;
227 fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value .AND. (config_flags%%periodic_x .OR. config_flags%%periodic_y )) THEN\n",commname ) ;
228
229 fprintf(fp," CALL wrf_debug ( 50 , 'setting up period %s' )\n",commname ) ;
230 fprintf(fp," CALL setup_period_rsl( grid )\n" ) ;
231 fprintf(fp," CALL reset_period\n") ;
232
233 /* pass through description again now and generate the calls */
234 strcpy( tmp, p->comm_define ) ;
235 strcpy( commuse, p->use ) ;
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 period %s\n", commname ) ; continue ; }
242 perwidth = atoi (t2) ;
243 t2 = strtok_rentr(NULL,",", &pos2) ;
244 while ( t2 != NULL )
245 {
246 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
247 {
248 fprintf(stderr,"WARNING 2 : %s in period spec %s is not defined in registry.\n",t2,commname) ;
249 }
250 else
251 {
252 if ( q->boundary_array )
253 {
254 fprintf(stderr,"WARNING: boundary array %s cannot be member of period spec %s.\n",t2,commname) ;
255 }
256 else
257 {
258
259 strcpy( varref, t2 ) ;
260 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
261 if ( !strncmp( q->use, "dyn_", 4 )) {
262 char * core ;
263 core = q->use+4 ;
264 sprintf(varref,"grid%%%s_%s",core,t2) ;
265 } else {
266 sprintf(varref,"grid%%%s",t2) ;
267 }
268 }
269
270 if ( q->node_kind & FOURD )
271 {
272 node_t *member ;
273 zdex = get_index_for_coord( q , COORD_Z ) ;
274 if ( zdex >=1 && zdex <= 3 )
275 {
276 for ( member = q->members ; member != NULL ; member = member->next )
277 {
278 if ( strcmp( member->name, "-" ) )
279 {
280 fprintf(fp," if ( P_%s .GT. 1 ) CALL add_msg_period_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
281 member->name, q->type->name, t2 , member->name, zdex+1 ) ;
282 }
283 }
284 }
285 else
286 {
287 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
288 }
289 }
290 else
291 {
292 strcpy (indices,"");
293 if ( sw_deref_kludge ) /* && strchr (t2, '%') != NULLCHARPTR ) */
294 {
295 sprintf(post,")") ;
296 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
297 }
298 dimd = get_dimnode_for_coord( q , COORD_Z ) ;
299 zdex = get_index_for_coord( q , COORD_Z ) ;
300 if ( dimd != NULL )
301 {
302 char dimstrg[256] ;
303
304 if ( dimd->len_defined_how == DOMAIN_STANDARD )
305 sprintf(dimstrg,"(glen(%d))",zdex+1) ;
306 else if ( dimd->len_defined_how == NAMELIST )
307 {
308 if ( !strcmp(dimd->assoc_nl_var_s,"1") )
309 sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
310 else
311 sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
312 }
313 else if ( dimd->len_defined_how == CONSTANT )
314 sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
315
316 fprintf(fp," CALL add_msg_period_%s ( %s%s , %s )\n", q->type->name, varref, indices, dimstrg ) ;
317 }
318 else if ( q->ndims == 2 ) /* 2d */
319 {
320 fprintf(fp," CALL add_msg_period_%s ( %s%s , %s )\n", q->type->name, varref, indices, "1" ) ;
321 }
322 }
323 }
324 q->subject_to_communication = 1 ; /* Indicate that this field may be communicated */
325 }
326 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
327 }
328 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
329 }
330 fprintf(fp," CALL period_def ( grid%%domdesc , grid%%comms ( %s ) , %d )\n",commname , maxperwidth ) ;
331 fprintf(fp,"ENDIF\n") ;
332 fprintf(fp,"IF ( config_flags%%periodic_x ) THEN\n") ;
333 fprintf(fp," CALL wrf_debug ( 50 , 'exchanging period %s on x' )\n",commname ) ;
334 fprintf(fp," CALL rsl_exch_period ( grid%%domdesc , grid%%comms( %s ) , x_period_flag )\n",commname ) ;
335 fprintf(fp,"END IF\n") ;
336 fprintf(fp,"IF ( config_flags%%periodic_y ) THEN\n") ;
337 fprintf(fp," CALL wrf_debug ( 50 , 'exchanging period %s on y' )\n",commname ) ;
338 fprintf(fp," CALL rsl_exch_period ( grid%%domdesc , grid%%comms( %s ) , y_period_flag )\n",commname ) ;
339 fprintf(fp,"END IF\n") ;
340
341 close_the_file(fp) ;
342 }
343 return(0) ;
344 }
345
346 int
347 gen_xposes ( char * dirname )
348 {
349 node_t * p, * q ;
350 char commname[NAMELEN] ;
351 char fname[NAMELEN] ;
352 char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ;
353 char commuse[NAMELEN_LONG] ;
354 FILE * fp ;
355 char * t1, * t2 ;
356 char * pos1 , * pos2 ;
357 char *xposedir[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
358 char ** x ;
359 char indices[NAMELEN], post[NAMELEN], varname[NAMELEN], varref[NAMELEN] ;
360
361 if ( dirname == NULL ) return(1) ;
362
363 for ( p = Xposes ; p != NULL ; p = p->next )
364 {
365 for ( x = xposedir ; *x ; x++ )
366 {
367 strcpy( commname, p->name ) ;
368 make_upper_case(commname) ;
369 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s_%s.inc",dirname,commname, *x) ; }
370 else { sprintf(fname,"%s_%s.inc",commname,*x) ; }
371 if ((fp = fopen( fname , "w" )) == NULL )
372 {
373 fprintf(stderr,"WARNING: gen_halos in registry cannot open %s for writing\n",fname ) ;
374 continue ;
375 }
376
377 print_warning(fp,fname) ;
378 fprintf(fp,"#ifndef DATA_CALLS_INCLUDED\n") ;
379 fprintf(fp,"--- DELIBERATE SYNTAX ERROR: THIS ROUTINE SHOULD INCLUDE \"%s_data_calls.inc\"\n",p->use+4) ;
380 fprintf(fp," BECAUSE IT CONTAINS AN RSL TRANSPOSE OPERATION\n" ) ;
381 fprintf(fp,"#endif\n") ;
382 fprintf(fp,"IF ( grid%%comms( %s ) == invalid_message_value ) THEN\n",commname ) ;
383
384 fprintf(fp," CALL wrf_debug ( 50 , 'setting up xpose %s' )\n",commname ) ;
385 fprintf(fp," CALL setup_xpose_rsl( grid )\n") ;
386 fprintf(fp," CALL reset_msgs_xpose\n" ) ;
387
388 strcpy( tmp, p->comm_define ) ;
389 strcpy( commuse, p->use ) ;
390 t1 = strtok_rentr( tmp , ";" , &pos1 ) ;
391 while ( t1 != NULL )
392 {
393 strcpy( tmp2 , t1 ) ;
394
395 /* Z array */
396 t2 = strtok_rentr(tmp2,",", &pos2) ;
397 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
398 { fprintf(stderr,"WARNING 3 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
399 strcpy( varref, t2 ) ;
400 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
401 if ( !strncmp( q->use, "dyn_", 4 )) {
402 char * core ;
403 core = q->use+4 ;
404 sprintf(varref,"grid%%%s_%s",core,t2) ;
405 } else {
406 sprintf(varref,"grid%%%s",t2) ;
407 }
408 }
409 if ( q->proc_orient != ALL_Z_ON_PROC )
410 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Z_ON_PROC.\n",t2,commname) ; goto skiperific ; }
411 if ( q->ndims != 3 )
412 { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
413 if ( q->boundary_array )
414 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
415 strcpy (indices,"");
416 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
417 {
418 sprintf(post,")") ;
419 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
420 }
421 fprintf(fp," CALL add_msg_xpose_%s ( %s%s ,", q->type->name, varref,indices ) ;
422 q->subject_to_communication = 1 ; /* Indicate that this field may be communicated */
423
424 /* X array */
425 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
426 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
427 { fprintf(stderr,"WARNING 4 : %s in xpose spec %s (%s) is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
428 strcpy( varref, t2 ) ;
429 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
430 if ( !strncmp( q->use, "dyn_", 4 )) {
431 char * core ;
432 core = q->use+4 ;
433 sprintf(varref,"grid%%%s_%s",core,t2) ;
434 } else {
435 sprintf(varref,"grid%%%s",t2) ;
436 }
437 }
438 if ( q->proc_orient != ALL_X_ON_PROC )
439 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_X_ON_PROC.\n",t2,commname) ; goto skiperific ; }
440 if ( q->ndims != 3 )
441 { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
442 if ( q->boundary_array )
443 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
444 strcpy (indices,"");
445 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
446 {
447 sprintf(post,")") ;
448 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
449 }
450 fprintf(fp," %s%s ,", varref, indices ) ;
451 q->subject_to_communication = 1 ; /* Indicate that this field may be communicated */
452
453 /* Y array */
454 t2 = strtok_rentr( NULL , "," , &pos2 ) ;
455 if ((q = get_entry_r( t2, commuse, Domain.fields )) == NULL )
456 { fprintf(stderr,"WARNING 5 : %s in xpose spec %s (%s)is not defined in registry.\n",t2,commname,commuse) ; goto skiperific ; }
457 strcpy( varref, t2 ) ;
458 if ( q->node_kind & FIELD && ! (q->node_kind & I1) ) {
459 if ( !strncmp( q->use, "dyn_", 4 )) {
460 char * core ;
461 core = q->use+4 ;
462 sprintf(varref,"grid%%%s_%s",core,t2) ;
463 } else {
464 sprintf(varref,"grid%%%s",t2) ;
465 }
466 }
467 if ( q->proc_orient != ALL_Y_ON_PROC )
468 { fprintf(stderr,"WARNING: %s in xpose spec %s is not ALL_Y_ON_PROC.\n",t2,commname) ; goto skiperific ; }
469 if ( q->ndims != 3 )
470 { fprintf(stderr,"WARNING: boundary array %s must be 3D to be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
471 if ( q->boundary_array )
472 { fprintf(stderr,"WARNING: boundary array %s cannot be member of xpose spec %s.\n",t2,commname) ; goto skiperific ; }
473 strcpy (indices,"");
474 if ( sw_deref_kludge && strchr (t2, '%') != NULLCHARPTR )
475 {
476 sprintf(post,")") ;
477 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,q,post)) ;
478 }
479 fprintf(fp," %s%s , 3 )\n", varref, indices ) ;
480 q->subject_to_communication = 1 ; /* Indicate that this field may be communicated */
481 t1 = strtok_rentr( NULL , ";" , &pos1 ) ;
482 }
483 fprintf(fp," CALL define_xpose ( grid%%domdesc , grid%%comms ( %s ) )\n", commname ) ;
484 fprintf(fp,"ENDIF\n") ;
485 fprintf(fp,"CALL wrf_debug ( 50 , 'calling wrf_dm_xpose_%s for %s')\n",*x,commname ) ;
486 fprintf(fp,"CALL wrf_dm_xpose_%s ( grid%%domdesc , grid%%comms, %s )\n", *x , commname ) ;
487
488 close_the_file(fp) ;
489 }
490 skiperific:
491 ;
492 }
493 return(0) ;
494 }
495
496 int
497 gen_comm_descrips ( char * dirname )
498 {
499 node_t * p ;
500 char * fn = "dm_comm_cpp_flags" ;
501 char commname[NAMELEN] ;
502 char fname[NAMELEN] ;
503 FILE * fp ;
504 int ncomm ;
505
506 if ( dirname == NULL ) return(1) ;
507
508 if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; }
509 else { sprintf(fname,"%s",fn) ; }
510
511 if ((fp = fopen( fname , "w" )) == NULL )
512 {
513 fprintf(stderr,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname ) ;
514 }
515
516 ncomm = 1 ;
517 for ( p = Halos ; p != NULL ; p = p->next )
518 {
519 strcpy( commname, p->name ) ;
520 make_upper_case(commname) ;
521 fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
522 }
523 for ( p = Periods ; p != NULL ; p = p->next )
524 {
525 strcpy( commname, p->name ) ;
526 make_upper_case(commname) ;
527 fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
528 }
529 for ( p = Xposes ; p != NULL ; p = p->next )
530 {
531 strcpy( commname, p->name ) ;
532 make_upper_case(commname) ;
533 fprintf(fp,"-D%s=%d\n",commname,ncomm++) ;
534 }
535 fprintf(fp,"-DWRF_RSL_NCOMMS=%d\n",ncomm-1 ) ;
536 return(0) ;
537 }
538
539 /*
540
541
542
543 */
544
545 /* for each core, generate the halo updates to allow shifting all state data */
546 int
547 gen_shift ( char * dirname )
548 {
549 int i, ncore ;
550 FILE * fp ;
551 node_t *p, *q, *dimd ;
552 char * corename ;
553 char **direction ;
554 char *directions[] = { "x", "y", 0L } ;
555 char fname[NAMELEN], vname[NAMELEN], vname2[NAMELEN], core[NAMELEN] ;
556 char indices[NAMELEN], post[NAMELEN], tmp3[NAMELEN] ;
557 int zdex ;
558 int said_it = 0 ;
559
560 for ( direction = directions ; *direction != NULL ; direction++ )
561 {
562 for ( ncore = 0 ; ncore < get_num_cores() ; ncore++ )
563 {
564 corename = get_corename_i(ncore) ;
565 if ( dirname == NULL || corename == NULL ) return(1) ;
566 if ( strlen(dirname) > 0 )
567 { sprintf(fname,"%s/%s_shift_halo_%s.inc",dirname,corename,*direction) ; }
568 else
569 { sprintf(fname,"%s_shift_halo_%s.inc",corename,*direction) ; }
570 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
571 print_warning(fp,fname) ;
572 fprintf(fp,"IF ( grid%%shift_%s == invalid_message_value ) THEN\n",*direction ) ;
573 fprintf(fp," CALL wrf_debug ( 50 , 'set up halo for %s shift' )\n",*direction ) ;
574 fprintf(fp," CALL setup_halo_rsl( grid )\n" ) ;
575 fprintf(fp," CALL reset_msgs_%s_shift\n", *direction ) ;
576
577 for ( p = Domain.fields ; p != NULL ; p = p->next )
578 {
579
580 /* special cases in WRF */
581 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
582 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
583 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
584 if ( sw_move && ! said_it ) { fprintf(stderr,"Info only - not an error: Moving nests not implemented for Grell Ens. Cumulus\n") ;
585 fprintf(stderr,"Info only - not an error: Moving nests not implemented for CAM radiation\n") ;
586 fprintf(stderr,"Info only - not an error: Moving nests not implemented for Observation Nudging\n") ;
587 said_it = 1 ; }
588 continue ;
589 }
590
591 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
592 ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
593 {
594
595 if ( p->node_kind & FOURD ) {
596 sprintf(core,"") ;
597 } else {
598 if (!strncmp( p->use, "dyn_", 4)) sprintf(core,"%s_",corename) ;
599 else sprintf(core,"") ;
600 }
601
602 /* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
603 if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
604 if ( p->type->type_type == SIMPLE )
605 {
606 for ( i = 1 ; i <= p->ntl ; i++ )
607 {
608 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
609 else sprintf(vname,"%s",p->name ) ;
610 if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
611 else sprintf(vname2,"%s%s",core,p->name ) ;
612 if ( p->node_kind & FOURD )
613 {
614 node_t *member ;
615 zdex = get_index_for_coord( p , COORD_Z ) ;
616 if ( zdex >=1 && zdex <= 3 )
617 {
618 for ( member = p->members ; member != NULL ; member = member->next )
619 {
620 if ( strcmp( member->name, "-" ) )
621 {
622 fprintf(fp,
623 " if ( P_%s .GT. 1 ) CALL add_msg_%s_shift_%s ( %s ( grid%%sm31,grid%%sm32,grid%%sm33,P_%s), glen(%d) )\n",
624 member->name, *direction, p->type->name, vname, member->name, zdex+1 ) ;
625 p->subject_to_communication = 1 ;
626 }
627 }
628 }
629 else
630 {
631 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
632 }
633 }
634 else
635 {
636 strcpy (indices,"");
637 if ( sw_deref_kludge ) /* && strchr (p->name, '%') != NULLCHARPTR ) */
638 {
639 sprintf(post,")") ;
640 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp3,p,post)) ;
641 }
642 dimd = get_dimnode_for_coord( p , COORD_Z ) ;
643 zdex = get_index_for_coord( p , COORD_Z ) ;
644 if ( dimd != NULL )
645 {
646 char dimstrg[256] ;
647
648 if ( dimd->len_defined_how == DOMAIN_STANDARD )
649 sprintf(dimstrg,"(glen(%d))",zdex+1) ;
650 else if ( dimd->len_defined_how == NAMELIST )
651 {
652 if ( !strcmp(dimd->assoc_nl_var_s,"1") )
653 sprintf(dimstrg,"config_flags%%%s",dimd->assoc_nl_var_e) ;
654 else
655 sprintf(dimstrg,"(config_flags%%%s - config_flags%%%s + 1)",dimd->assoc_nl_var_e,dimd->assoc_nl_var_s) ;
656 }
657 else if ( dimd->len_defined_how == CONSTANT )
658 sprintf(dimstrg,"(%d - %d + 1)",dimd->coord_end,dimd->coord_start) ;
659
660 fprintf(fp," CALL add_msg_%s_shift_%s ( grid%%%s%s , %s )\n", *direction, p->type->name, vname2, indices, dimstrg ) ;
661 p->subject_to_communication = 1 ;
662 }
663 else if ( p->ndims == 2 ) /* 2d */
664 {
665 fprintf(fp," CALL add_msg_%s_shift_%s ( grid%%%s%s , %s )\n", *direction, p->type->name, vname2, indices, "1" ) ;
666 p->subject_to_communication = 1 ;
667 }
668 }
669 }
670 }
671 }
672 }
673 }
674 fprintf(fp," CALL stencil_%s_shift ( grid%%domdesc , grid%%shift_%s )\n", *direction , *direction ) ;
675 fprintf(fp,"ENDIF\n") ;
676 fprintf(fp," CALL wrf_debug ( 50 , 'exchange halo for %s shift' )\n",*direction ) ;
677 fprintf(fp,"CALL rsl_exch_stencil ( grid%%domdesc , grid%%shift_%s )\n", *direction ) ;
678
679 for ( p = Domain.fields ; p != NULL ; p = p->next )
680 {
681
682 /* special cases in WRF */
683 if ( !strcmp( p->name , "xf_ens" ) || !strcmp( p->name , "pr_ens" ) ||
684 !strcmp( p->name , "abstot" ) || !strcmp( p->name , "absnxt" ) ||
685 !strcmp( p->name , "emstot" ) || !strcmp( p->name , "obs_savwt" ) ) {
686 continue ;
687 }
688 if ( p->node_kind & FOURD ) {
689 sprintf(core,"") ;
690 } else {
691 if (!strncmp( p->use, "dyn_", 4)) sprintf(core,"%s_",corename) ;
692 else sprintf(core,"") ;
693 }
694
695 if (( p->node_kind & (FIELD | FOURD) ) && p->ndims >= 2 && ! p->boundary_array &&
696 ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
697 {
698 /* make sure that the only things we are shifting are arrays that have a decomposed X and a Y dimension */
699 if ( get_dimnode_for_coord( p , COORD_X ) && get_dimnode_for_coord( p , COORD_Y ) ) {
700 if ( p->type->type_type == SIMPLE )
701 {
702 for ( i = 1 ; i <= p->ntl ; i++ )
703 {
704 if ( p->ntl > 1 ) sprintf(vname,"%s_%d",p->name,i ) ;
705 else sprintf(vname,"%s",p->name ) ;
706 if ( p->ntl > 1 ) sprintf(vname2,"%s%s_%d",core,p->name,i ) ;
707 else sprintf(vname2,"%s%s",core,p->name ) ;
708
709 if ( p->node_kind & FOURD )
710 {
711 node_t *member ;
712 zdex = get_index_for_coord( p , COORD_Z ) ;
713 if ( zdex >=1 && zdex <= 3 )
714 {
715 for ( member = p->members ; member != NULL ; member = member->next )
716 {
717 if ( strcmp( member->name, "-" ) )
718 {
719 if ( !strcmp( *direction, "x" ) )
720 {
721 fprintf(fp,
722 " if ( P_%s .GT. 1 ) %s ( ips:min(ide%s,ipe),:,jms:jme,P_%s) = %s (ips+px:min(ide%s,ipe)+px,:,jms:jme,P_%s)\n",
723 member->name, vname, member->stag_x?"":"-1", member->name, vname, member->stag_x?"":"-1", member->name ) ;
724 }
725 else
726 {
727 fprintf(fp,
728 " if ( P_%s .GT. 1 ) %s ( ims:ime,:,jps:min(jde%s,jpe),P_%s) = %s (ims:ime,:,jps+py:min(jde%s,jpe)+py,P_%s)\n",
729 member->name, vname, member->stag_y?"":"-1", member->name, vname, member->stag_y?"":"-1", member->name ) ;
730 }
731 }
732 }
733 }
734 else
735 {
736 fprintf(stderr,"WARNING: %d some dimension info missing for 4d array %s\n",zdex,t2) ;
737 }
738 }
739 else
740 {
741 char * vdim ;
742 vdim = "" ;
743 if ( p->ndims == 3 ) vdim = ":," ;
744 if ( !strcmp( *direction, "x" ) )
745 {
746 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 ) ;
747 }
748 else
749 {
750 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" ) ;
751 }
752 }
753 }
754 }
755 }
756 }
757 }
758 close_the_file(fp) ;
759 }
760 }
761 }
762
763 int
764 gen_datacalls ( char * dirname )
765 {
766 int i ;
767 FILE * fp ;
768 char * corename ;
769 char * fn = "data_calls.inc" ;
770 char fname[NAMELEN] ;
771
772 for ( i = 0 ; i < get_num_cores() ; i++ )
773 {
774 corename = get_corename_i(i) ;
775 if ( dirname == NULL || corename == NULL ) return(1) ;
776 if ( strlen(dirname) > 0 )
777 { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
778 else
779 { sprintf(fname,"%s_%s",corename,fn) ; }
780 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
781 print_warning(fp,fname) ;
782 fprintf(fp," CALL rsl_start_register_f90\n") ;
783 parent_type = SIMPLE;
784 gen_datacalls1( fp , corename, "grid%", FIELD , Domain.fields ) ;
785 gen_datacalls1( fp , corename, "", FOURD , Domain.fields ) ;
786 fprintf(fp,"#ifdef REGISTER_I1\n") ;
787 gen_datacalls1( fp , corename, "", I1 , Domain.fields ) ;
788 fprintf(fp,"#endif\n") ;
789 fprintf(fp," CALL rsl_end_register_f90\n") ;
790 fprintf(fp,"#define DATA_CALLS_INCLUDED\n") ;
791 close_the_file(fp) ;
792 }
793 return(0) ;
794 }
795
796 int
797 gen_datacalls1 ( FILE * fp , char * corename , char * structname , int mask , node_t * node )
798 {
799 node_t * p, * q ;
800 int i, member_number ;
801 char tmp[NAMELEN],tmp2[NAMELEN], tc ;
802 char indices[NAMELEN], post[NAMELEN] ;
803 char s0[NAMELEN], s1[NAMELEN], s2[NAMELEN] ;
804 char e0[NAMELEN], e1[NAMELEN], e2[NAMELEN] ;
805
806 for ( p = node ; p != NULL ; p = p->next )
807 {
808 if ( ( mask & p->node_kind ) &&
809 ((!strncmp(p->use,"dyn_",4) && !strcmp(corename,p->use+4)) || strncmp(p->use,"dyn_",4)))
810 {
811 if ( (p->subject_to_communication == 1) || ( p->type->type_type == DERIVED ) )
812 {
813 if ( p->type->type_type == SIMPLE )
814 {
815 if ( !strcmp( p->type->name , "real" ) ) tc = 'R' ;
816 if ( !strcmp( p->type->name , "double" ) ) tc = 'D' ;
817 if ( !strcmp( p->type->name , "integer" ) ) tc = 'I' ;
818 for ( i = 1 ; i <= p->ntl ; i++ )
819 {
820 /* IF (P_QI .ge. P_FIRST_SCALAR */
821 if ( p->members != NULL ) /* a 4d array */
822 {
823 member_number = 0 ;
824 for ( q = p->members ; q != NULL ; q = q->next )
825 {
826 get_elem( "grid%", "", s0, 0, p , 0 ) ;
827 get_elem( "grid%", "", s1, 1, p , 0 ) ;
828 get_elem( "grid%", "", s2, 2, p , 0 ) ;
829
830 get_elem( "grid%", "", e0, 0, p , 1 ) ;
831 get_elem( "grid%", "", e1, 1, p , 1 ) ;
832 get_elem( "grid%", "", e2, 2, p , 1 ) ;
833
834 sprintf(tmp, "(%s,%s,%s,1+%d)", s0, s1, s2, member_number ) ;
835 sprintf(tmp2, "(%s-%s+1)*(%s-%s+1)*(%s-%s+1)*%cWORDSIZE",e0,s0,e1,s1,e2,s2,tc) ;
836 if ( p->ntl > 1 ) fprintf(fp," IF(1+%d.LE.num_%s)CALL rsl_register_f90_base_and_size ( %s%s_%d %s , &\n %s )\n",
837 member_number,p->name,structname,p->name,i,tmp,tmp2) ;
838 else fprintf(fp," IF(1+%d.LE.num_%s)CALL rsl_register_f90_base_and_size ( %s%s %s, &\n %s )\n",
839 member_number,p->name,structname,p->name,tmp,tmp2) ;
840 member_number++ ;
841 }
842 }
843 else
844 {
845 char ca[NAMELEN] ;
846 strcpy (indices,"");
847 if ( sw_deref_kludge )
848 {
849 sprintf(post,")") ;
850 sprintf(indices, "%s",index_with_firstelem("(","",-1,tmp,p,post)) ;
851 }
852 strcpy( ca, "" ) ;
853 if (!strncmp( p->use , "dyn_", 4 )) { char * cb ; cb = p->use+4 ; sprintf(ca,"%s_", cb) ; }
854 if ( p->ntl > 1 ) fprintf(fp," CALL rsl_register_f90_base_and_size ( %s%s%s_%d%s , SIZE( %s%s%s_%d ) * %cWORDSIZE )\n",
855 structname,ca,p->name,i,indices,
856 structname,ca,p->name,i,tc ) ;
857 else fprintf(fp," CALL rsl_register_f90_base_and_size ( %s%s%s%s , SIZE( %s%s%s ) * %cWORDSIZE )\n",
858 structname,ca,p->name,indices,
859 structname,ca,p->name, tc) ;
860 }
861 }
862 }
863 else if ( p->type->type_type == DERIVED )
864 {
865 parent_type = DERIVED;
866 sprintf( tmp , "grid%%%s%%", p->name ) ;
867 gen_datacalls1 ( fp , corename , tmp , mask, p->type->fields ) ;
868 }
869 }
870 }
871 }
872 return(0) ;
873 }
874
875 /*****************/
876 /*****************/
877
878 gen_nest_packing ( char * dirname )
879 {
880 gen_nest_pack( dirname ) ;
881 gen_nest_unpack( dirname ) ;
882 }
883
884 #define PACKIT 1
885 #define UNPACKIT 2
886
887 int
888 gen_nest_pack ( char * dirname )
889 {
890 int i ;
891 FILE * fp ;
892 char * corename ;
893 char * fnlst[] = { "nest_interpdown_pack.inc" , "nest_forcedown_pack.inc" , "nest_feedbackup_pack.inc", 0L } ;
894 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
895 int ipath ;
896 char ** fnp ; char * fn ;
897 char fname[NAMELEN] ;
898 node_t *node, *p, *dim ;
899 int xdex, ydex, zdex ;
900 char ddim[3][2][NAMELEN] ;
901 char mdim[3][2][NAMELEN] ;
902 char pdim[3][2][NAMELEN] ;
903 char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
904 int d2, d3 ;
905
906 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
907 {
908 fn = *fnp ;
909 for ( i = 0 ; i < get_num_cores() ; i++ )
910 {
911 corename = get_corename_i(i) ;
912 if ( dirname == NULL || corename == NULL ) return(1) ;
913 if ( strlen(dirname) > 0 ) {
914 if ( strlen( corename ) > 0 )
915 { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
916 else
917 { sprintf(fname,"%s/%s",dirname,fn) ; }
918 } else {
919 if ( strlen( corename ) > 0 )
920 { sprintf(fname,"%s_%s",corename,fn) ; }
921 else
922 { sprintf(fname,"%s",fn) ; }
923 }
924 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
925 print_warning(fp,fname) ;
926
927 d2 = 0 ;
928 d3 = 0 ;
929 node = Domain.fields ;
930
931 count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
932
933 if ( d2 + d3 > 0 ) {
934 if ( down_path[ipath] == INTERP_UP )
935 {
936
937 fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
938 fprintf(fp,"CALL rsl_to_parent_info( grid%%domdesc, intermediate_grid%%domdesc , &\n") ;
939 fprintf(fp," msize*RWORDSIZE, &\n") ;
940 fprintf(fp," i,j,nig,njg,cm,cn,pig,pjg,retval )\n") ;
941 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
942
943 gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
944
945 fprintf(fp,"CALL rsl_to_parent_info( grid%%domdesc, intermediate_grid%%domdesc , &\n") ;
946 fprintf(fp," msize*RWORDSIZE, &\n") ;
947 fprintf(fp," i,j,nig,njg,cm,cn,pig,pjg,retval )\n") ;
948 fprintf(fp,"ENDDO\n") ;
949
950 }
951 else
952 {
953
954 fprintf(fp,"msize = %d * nlev + %d\n", d3, d2 ) ;
955 fprintf(fp,"CALL rsl_to_child_info( grid%%domdesc, intermediate_grid%%domdesc , &\n") ;
956 fprintf(fp," msize*RWORDSIZE, &\n") ;
957 fprintf(fp," i,j,pig,pjg,cm,cn,nig,njg,retval )\n") ;
958 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
959
960 gen_nest_packunpack ( fp , Domain.fields, corename, PACKIT, down_path[ipath] ) ;
961
962 fprintf(fp,"CALL rsl_to_child_info( grid%%domdesc, intermediate_grid%%domdesc , &\n") ;
963 fprintf(fp," msize*RWORDSIZE, &\n") ;
964 fprintf(fp," i,j,pig,pjg,cm,cn,nig,njg,retval )\n") ;
965 fprintf(fp,"ENDDO\n") ;
966
967 }
968 }
969
970 close_the_file(fp) ;
971 }
972 }
973 return(0) ;
974 }
975
976 int
977 gen_nest_unpack ( char * dirname )
978 {
979 int i ;
980 FILE * fp ;
981 char * corename ;
982 char * fnlst[] = { "nest_interpdown_unpack.inc" , "nest_forcedown_unpack.inc" , "nest_feedbackup_unpack.inc" , 0L } ;
983 int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ;
984 int ipath ;
985 char ** fnp ; char * fn ;
986 char fname[NAMELEN] ;
987 node_t *node, *p, *dim ;
988 int xdex, ydex, zdex ;
989 char ddim[3][2][NAMELEN] ;
990 char mdim[3][2][NAMELEN] ;
991 char pdim[3][2][NAMELEN] ;
992 char vname[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
993 int d2, d3 ;
994
995 for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ )
996 {
997 fn = *fnp ;
998 for ( i = 0 ; i < get_num_cores() ; i++ )
999 {
1000 d2 = 0 ;
1001 d3 = 0 ;
1002 node = Domain.fields ;
1003
1004 corename = get_corename_i(i) ;
1005 if ( dirname == NULL || corename == NULL ) return(1) ;
1006 if ( strlen(dirname) > 0 )
1007 { sprintf(fname,"%s/%s_%s",dirname,corename,fn) ; }
1008 else
1009 { sprintf(fname,"%s_%s",corename,fn) ; }
1010 if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
1011 print_warning(fp,fname) ;
1012
1013 count_fields ( node , &d2 , &d3 , corename , down_path[ipath] ) ;
1014
1015 if ( d2 + d3 > 0 ) {
1016 if ( down_path[ipath] == INTERP_UP )
1017 {
1018
1019 fprintf(fp,"CALL rsl_from_child_info(i,j,pig,pjg,cm,cn,nig,njg,retval)\n") ;
1020 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1021
1022 gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
1023
1024 fprintf(fp,"CALL rsl_from_child_info(i,j,pig,pjg,cm,cn,nig,njg,retval)\n") ;
1025 fprintf(fp,"ENDDO\n") ;
1026
1027 }
1028 else
1029 {
1030
1031 fprintf(fp,"CALL rsl_from_parent_info(i,j,nig,njg,cm,cn,pig,pjg,retval)\n") ;
1032 fprintf(fp,"DO while ( retval .eq. 1 )\n") ;
1033 gen_nest_packunpack ( fp , Domain.fields, corename, UNPACKIT, down_path[ipath] ) ;
1034 fprintf(fp,"CALL rsl_from_parent_info(i,j,nig,njg,cm,cn,pig,pjg,retval)\n") ;
1035 fprintf(fp,"ENDDO\n") ;
1036
1037 }
1038 }
1039
1040 close_the_file(fp) ;
1041 }
1042 }
1043 return(0) ;
1044 }
1045
1046 int
1047 gen_nest_packunpack ( FILE *fp , node_t * node , char * corename, int dir, int down_path )
1048 {
1049 int i ;
1050 node_t *p, *p1, *dim ;
1051 int d2, d3, xdex, ydex, zdex ;
1052 char ddim[3][2][NAMELEN] ;
1053 char mdim[3][2][NAMELEN] ;
1054 char pdim[3][2][NAMELEN] ;
1055 char vname[NAMELEN], vname2[NAMELEN], dexes[NAMELEN] ; char tag[NAMELEN] ; char core[NAMELEN] ;
1056 char c, d ;
1057
1058 for ( p1 = node ; p1 != NULL ; p1 = p1->next )
1059 {
1060
1061 if ( p1->node_kind & FOURD )
1062 {
1063 gen_nest_packunpack ( fp, p1->members, corename, dir , down_path ) ; /* RECURSE over members */
1064 continue ;
1065 }
1066 else
1067 {
1068 p = p1 ;
1069 }
1070
1071 if ( p->io_mask & down_path )
1072 {
1073 if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
1074 {
1075
1076 if (!strncmp( p->use, "dyn_", 4)) sprintf(core,"%s",corename) ;
1077 else sprintf(core,"") ;
1078
1079 if ( p->ntl > 1 ) sprintf(tag,"_2") ;
1080 else sprintf(tag,"") ;
1081
1082 set_dim_strs ( p , ddim , mdim , pdim , "c", 0 ) ;
1083 zdex = get_index_for_coord( p , COORD_Z ) ;
1084 xdex = get_index_for_coord( p , COORD_X ) ;
1085 ydex = get_index_for_coord( p , COORD_Y ) ;
1086
1087 if ( down_path == INTERP_UP )
1088 {
1089 c = ( dir == PACKIT )?'n':'p' ;
1090 d = ( dir == PACKIT )?'2':'1' ;
1091 } else {
1092 c = ( dir == UNPACKIT )?'n':'p' ;
1093 d = ( dir == UNPACKIT )?'2':'1' ;
1094 }
1095
1096 if ( zdex >= 0 ) {
1097 if ( xdex == 0 && zdex == 1 && ydex == 2 ) sprintf(dexes,"pig,k,pjg") ;
1098 else if ( zdex == 0 && xdex == 1 && ydex == 2 ) sprintf(dexes,"k,pig,pjg") ;
1099 else if ( xdex == 0 && ydex == 1 && zdex == 2 ) sprintf(dexes,"pig,pjg,k") ;
1100 } else {
1101 if ( xdex == 0 && ydex == 1 ) sprintf(dexes,"pig,pjg") ;
1102 if ( ydex == 0 && xdex == 1 ) sprintf(dexes,"pjg,pig") ;
1103 }
1104
1105 /* construct variable name */
1106 if ( p->scalar_array_member )
1107 {
1108 sprintf(vname,"%s%s(%s,P_%s)",p->use,tag,dexes,p->name) ;
1109 if ( strlen(core) > 0 )
1110 sprintf(vname2,"%s_%s%s(%s,P_%s)",core,p->use,tag,dexes,p->name) ;
1111 else
1112 sprintf(vname2,"%s%s(%s,P_%s)",p->use,tag,dexes,p->name) ;
1113 }
1114 else
1115 {
1116 sprintf(vname,"%s%s(%s)",p->name,tag,dexes) ;
1117 if ( strlen(core) > 0 )
1118 sprintf(vname2,"%s_%s%s(%s)",core,p->name,tag,dexes) ;
1119 else
1120 sprintf(vname2,"%s%s(%s)",p->name,tag,dexes) ;
1121 }
1122
1123 if ( p->scalar_array_member )
1124 {
1125 fprintf(fp,"IF ( P_%s .GE. PARAM_FIRST_SCALAR ) THEN\n",p->name) ;
1126 }
1127
1128 if ( dir == UNPACKIT )
1129 {
1130 if ( down_path == INTERP_UP )
1131 {
1132 if ( zdex >= 0 ) {
1133 fprintf(fp,"CALL rsl_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim[zdex][1], ddim[zdex][0] ) ;
1134 } else {
1135 fprintf(fp,"CALL rsl_from_child_msg(RWORDSIZE,xv)\n" ) ;
1136 }
1137 fprintf(fp,"IF ( %s_cd_feedback_mask( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
1138 corename, p->stag_x?".TRUE.":".FALSE." ,p->stag_y?".TRUE.":".FALSE." ) ;
1139 if ( zdex >= 0 ) {
1140 fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(grid%%%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], vname2 ) ;
1141 } else {
1142 fprintf(fp,"grid%%%s = xv(1) ;\n", vname2) ;
1143 }
1144 fprintf(fp,"ENDIF\n") ;
1145 }
1146 else
1147 {
1148 if ( zdex >= 0 ) {
1149 fprintf(fp,"CALL rsl_from_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\nDO k = %s,%s\ngrid%%%s = xv(k)\nENDDO\n",
1150 ddim[zdex][1], ddim[zdex][0], ddim[zdex][0], ddim[zdex][1], vname2) ;
1151 } else {
1152 fprintf(fp,"CALL rsl_from_parent_msg(RWORDSIZE,xv)\ngrid%%%s = xv(1)\n", vname2) ;
1153 }
1154 }
1155 }
1156 else
1157 {
1158 if ( down_path == INTERP_UP )
1159 {
1160 if ( zdex >= 0 ) {
1161 fprintf(fp,"DO k = %s,%s\nxv(k)= intermediate_grid%%%s\nENDDO\nCALL rsl_to_parent_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1162 ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
1163 } else {
1164 fprintf(fp,"xv(1)= intermediate_grid%%%s\nCALL rsl_to_parent_msg(RWORDSIZE,xv)\n", vname2) ;
1165 }
1166 }
1167 else
1168 {
1169 if ( zdex >= 0 ) {
1170 fprintf(fp,"DO k = %s,%s\nxv(k)= grid%%%s\nENDDO\nCALL rsl_to_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv)\n",
1171 ddim[zdex][0], ddim[zdex][1], vname2, ddim[zdex][1], ddim[zdex][0] ) ;
1172 } else {
1173 fprintf(fp,"xv(1)=grid%%%s\nCALL rsl_to_child_msg(RWORDSIZE,xv)\n", vname2) ;
1174 }
1175 }
1176 }
1177 if ( p->scalar_array_member )
1178 {
1179 fprintf(fp,"ENDIF\n") ;
1180 }
1181 }
1182 }
1183 }
1184
1185 return(0) ;
1186 }
1187
1188 /*****************/
1189
1190 int
1191 count_fields ( node_t * node , int * d2 , int * d3 , char * corename , int down_path )
1192 {
1193 node_t * p ;
1194 int zdex ;
1195 /* count up the total number of levels from all fields */
1196 for ( p = node ; p != NULL ; p = p->next )
1197 {
1198 if ( p->node_kind == FOURD )
1199 {
1200 count_fields( p->members , d2 , d3 , corename , down_path ) ; /* RECURSE */
1201 }
1202 else
1203 {
1204 if ( p->io_mask & down_path )
1205 {
1206 if ((!strncmp( p->use, "dyn_", 4) && !strcmp(p->use+4,corename)) || strncmp( p->use, "dyn_", 4))
1207 {
1208 if ( p->node_kind == FOURD )
1209 zdex = get_index_for_coord( p->members , COORD_Z ) ;
1210 else
1211 zdex = get_index_for_coord( p , COORD_Z ) ;
1212
1213 if ( zdex < 0 ) {
1214 (*d2)++ ; /* if no zdex then only 2 d */
1215 } else {
1216 (*d3)++ ; /* if has a zdex then 3 d */
1217 }
1218 }
1219 }
1220 }
1221 }
1222 return(0) ;
1223 }
1224
1225 /*****************/
1226
1227 int
1228 gen_comms ( char * dirname )
1229 {
1230 if ( sw_dm_parallel )
1231 fprintf(stderr,"ADVISORY: RSL version of gen_comms is linked in with registry program.\n") ;
1232
1233 gen_halos( "inc" ) ;
1234 gen_shift( "inc" ) ;
1235 gen_periods( "inc" ) ;
1236 gen_xposes( "inc" ) ;
1237 gen_comm_descrips( "inc" ) ;
1238 gen_datacalls( "inc" ) ;
1239 gen_nest_packing( "inc" ) ;
1240
1241 return(0) ;
1242 }
1243
A coupled weather-fire forecasting model built on top of Weather Research and Forecasting (WRF).