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