6 #define index(X,Y) strchr(X,Y)
13 /* For detecting variables that are members of a derived type */
14 #define NULLCHARPTR (char *) 0
15 static int parent_type
;
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 */)
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
;
30 char indices
[NAMELEN
], post
[NAMELEN
], memord
[NAMELEN
] ;
33 set_mark( 0, Domain
.fields
) ;
35 strcpy( tmp
, p
->comm_define
) ;
36 strcpy( commuse
, p
->use
) ;
37 t1
= strtok_rentr( tmp
, ";" , &pos1
) ;
41 if (( t2
= strtok_rentr( tmp2
, ":" , &pos2
)) == NULL
)
43 fprintf(stderr
,"unparseable description for halo %s\n", p
->name
) ; continue ;
45 t2
= strtok_rentr(NULL
,",", &pos2
) ;
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
) ; }
52 strcpy( varref
, t2
) ;
53 if ( q
->node_kind
& FIELD
&& ! (q
->node_kind
& I1
) ) {
54 sprintf(varref
,"grid%%%s",t2
) ;
57 if ( strcmp( q
->type
->name
, "real") && strcmp( q
->type
->name
, "integer") && strcmp( q
->type
->name
, "doubleprecision") ) { ; }
58 else if ( q
->boundary_array
) { ; }
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
)
67 zdex
= get_index_for_coord( q
, COORD_Z
) ;
68 if ( zdex
>=1 && zdex
<= 3 )
70 set_mem_order( q
->members
, memord
, 3 ) ;
72 /* actual or dummy argument */
74 /* explicit dummy or actual arguments for 4D arrays */
76 fprintf(fp
," num_%s, &\n",q
->name
) ;
77 for ( d
= 3 ; d
< q
->ndims
; d
++ ) {
78 char *colon
, r
[80],tx
[80] ;
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) ;
85 fprintf(fp
,"%s,%s,&\n",tx
,colon
+1) ;
91 fprintf(fp
," %s, &\n",varref
) ;
95 /* declaration of dummy arguments for 4D arrays */
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) ;
104 strcpy(moredims
,"") ;
105 for ( d
= 3 ; d
< q
->ndims
; d
++ ) {
107 sprintf(temp
,",%s_sdim%d:%s_edim%d",q
->name
,d
-2,q
->name
,d
-2) ;
108 strcat(moredims
,temp
) ;
110 strcat(moredims
,",") ;
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
) ;
118 fprintf(stderr
,"WARNING: %d some dimension info missing for 4d array %s\n",zdex
,t2
) ;
121 else if ( q
->node_kind
& I1
)
125 /* explicit dummy or actual arguments for i1 arrays */
126 fprintf(fp
," %s, &\n",varref
) ;
130 /* declaration of dummy arguments for i1 arrays */
132 dimspec
=dimension_with_ranges( "grid%","(",-1,tmp3
,q
,")","" ) ;
133 fprintf(fp
," %s, INTENT(INOUT) :: %s %s\n", q
->type
->name
, varref
, dimspec
) ;
138 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
140 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
144 int print_call_or_def( FILE * fp
, node_t
*p
, char * callorsub
,
145 char * commname
, char * communicator
,
146 int need_config_flags
)
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") ;
160 int print_decl( FILE * fp
, node_t
*p
, char * communicator
,
161 int need_config_flags
)
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") ;
183 int print_body( FILE * fp
, char * commname
)
186 fprintf(fp
,"#ifdef DM_PARALLEL\n") ;
187 fprintf(fp
,"#include \"%s_inline.inc\"\n",commname
) ;
188 fprintf(fp
,"#endif\n") ;
190 fprintf(fp
," END SUBROUTINE %s_sub\n",commname
) ;
194 gen_halos ( char * dirname
, char * incname
, node_t
* halos
, int split
)
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
] ;
206 int maxstenwidth_int
, stenwidth
;
207 char maxstenwidth
[NAMELEN
] ;
212 char * pos1
, * pos2
;
213 char indices
[NAMELEN
], post
[NAMELEN
] ;
221 int need_config_flags
;
222 #define MAX_4DARRAYS 1000
223 char name_4d
[MAX_4DARRAYS
][NAMELEN
] ;
225 int num_halos
, fraction
, ihalo
, j
;
227 if ( dirname
== NULL
) return(1) ;
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
) ;
236 strcpy( commname
, incname
) ;
238 if ( !( !strcmp(commname
,"HALO_INTERP_DOWN") || !strcmp(commname
,"HALO_FORCE_DOWN" )
239 || !strcmp(commname
,"HALO_INTERP_UP" ) || !strcmp(commname
,"HALO_INTERP_SMOOTH" ) ) ) {
246 for ( p
= halos
; p
!= NULL
; p
= p
->next
)
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
) ;
254 strcpy( commname
, incname
) ;
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
)
264 fprintf(stderr
,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamecall
) ;
267 print_warning(fpcall
,fnamecall
) ;
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" ) ;
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
) ;
278 sprintf(subs_fname
, "REGISTRY_COMM_DM_subs.inc" ) ;
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
)
287 fprintf(stderr
,"WARNING: gen_halos in registry cannot open %s for writing\n",fnamesub
) ;
290 print_warning(fpsub
,fnamesub
) ;
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
) ; }
297 /* Generate inlined comm calls */
298 if ((fp
= fopen( fname
, "w" )) == NULL
)
300 fprintf(stderr
,"WARNING: gen_halos in registry cannot open %s for writing\n",fname
) ;
303 /* get maximum stencil width */
304 maxstenwidth_int
= 0 ;
305 strcpy( tmp
, p
->comm_define
) ;
306 t1
= strtok_rentr( tmp
, ";" , &pos1
) ;
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") ) {
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 */
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 ;
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
;
330 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
333 if ( maxstenwidth_int
== -99 ) {
334 sprintf(maxstenwidth
,"grid%%parent_grid_ratio") ;
336 sprintf(maxstenwidth
,"%d",maxstenwidth_int
) ;
339 print_warning(fp
,fname
) ;
341 fprintf(fp
,"CALL wrf_debug(2,'calling %s')\n",fname
) ;
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 ;
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 */
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
) ;
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
) ; }
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
) ;
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
) ; }
378 /* 20061004 -- collect all the vertical dimensions so we can use a MAX
379 on them when calling RSL_LITE_INIT_EXCH */
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
) {
388 else if ( dimd
->len_defined_how
== NAMELIST
) {
389 need_config_flags
= 1;
390 if ( !strcmp(dimd
->assoc_nl_var_s
,"1") ) {
392 sprintf(e
,"config_flags%%%s",dimd
->assoc_nl_var_e
) ;
394 sprintf(s
,"config_flags%%%s",dimd
->assoc_nl_var_s
) ;
395 sprintf(e
,"config_flags%%%s",dimd
->assoc_nl_var_e
) ;
398 else if ( dimd
->len_defined_how
== CONSTANT
) {
399 sprintf(s
,"%d",dimd
->coord_start
) ;
400 sprintf(e
,"%d",dimd
->coord_end
) ;
402 for ( i
= 0, foundvdim
= 0 ; i
< vdimcurs
; i
++ ) {
403 if ( !strcmp( vdims
[i
][1], e
) ) {
404 foundvdim
= 1 ; break ;
408 if (vdimcurs
< 100 ) {
409 strcpy( vdims
[vdimcurs
][0], s
) ;
410 strcpy( vdims
[vdimcurs
][1], e
) ;
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") ;
422 if ( q
->node_kind
& FOURD
) {
423 if ( n4d
< MAX_4DARRAYS
) {
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
) ;
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") ;
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
++ ; }
454 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
456 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
459 /* generate the stencil init statement for Y transfer */
461 fprintf(fp
,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxstenwidth
,fname
) ;
463 if ( subgrid
!= 0 ) {
464 fprintf(fp
,"IF ( grid%%sr_y .GT. 0 ) THEN\n") ;
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" ) ;
476 fprintf(fp
, " %d &\n", n3dR
) ;
477 for ( i
= 0 ; i
< n4d
; i
++ ) {
478 fprintf(fp
," + num_%s &\n", name_4d
[i
] ) ;
480 fprintf(fp
," , %d, RWORDSIZE, &\n", n2dR
) ;
482 fprintf(fp
," %d, %d, RWORDSIZE, &\n", n3dR
, n2dR
) ;
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] ) ;
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") ;
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") ;
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" ) ;
517 fprintf(fp
, " %d &\n", n3dR
) ;
518 for ( i
= 0 ; i
< n4d
; i
++ ) {
519 fprintf(fp
," + num_%s &\n", name_4d
[i
] ) ;
521 fprintf(fp
," , %d, RWORDSIZE, &\n", n2dR
) ;
523 fprintf(fp
," %d, %d, RWORDSIZE, &\n", n3dR
, n2dR
) ;
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] ) ;
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") ;
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") ;
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
) ;
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
)
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
] ;
579 strcpy( tmp
, p
->comm_define
) ;
580 strcpy( commuse
, p
->use
) ;
581 t1
= strtok_rentr( tmp
, ";" , &pos1
) ;
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
) ;
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
) ; }
595 strcpy( varname
, t2
) ;
596 strcpy( varref
, t2
) ;
597 if ( q
->node_kind
& FIELD
&& ! (q
->node_kind
& I1
) ) {
598 sprintf(varref
,"grid%%%s",t2
) ;
601 if ( strcmp( q
->type
->name
, "real") && strcmp( q
->type
->name
, "integer") && strcmp( q
->type
->name
, "doubleprecision") ) { ; }
602 else if ( q
->boundary_array
) { ; }
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
)
611 zdex
= get_index_for_coord( q
, COORD_Z
) ;
612 if ( zdex
>=1 && zdex
<= 3 )
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 ) ;
623 for ( d
= 3 ; d
< q
->ndims
; d
++ ) {
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
) ;
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") ;
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") ;
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") ;
650 fprintf(fp
," ENDIF\n") ;
651 for ( d
= 3 ; d
< q
->ndims
; d
++ ) {
652 fprintf(fp
," ENDDO ! idim%d \n",d
-2 ) ;
655 fprintf(fp
,"ENDDO\n") ;
659 fprintf(stderr
,"WARNING: %d some dimension info missing for 4d array %s\n",zdex
,t2
) ;
664 set_mem_order( q
, memord
, 3 ) ;
665 if ( q
->ndims
== 3 ) {
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 ) ;
674 char s
[256], e
[256] ;
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") ;
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") ;
690 else if ( dimd
->len_defined_how
== NAMELIST
)
692 if ( !strcmp(dimd
->assoc_nl_var_s
,"1") ) {
694 sprintf(e
,"config_flags%%%s",dimd
->assoc_nl_var_e
) ;
696 sprintf(s
,"config_flags%%%s",dimd
->assoc_nl_var_s
) ;
697 sprintf(e
,"config_flags%%%s",dimd
->assoc_nl_var_e
) ;
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
) ;
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
) ;
712 else if ( dimd
->len_defined_how
== CONSTANT
)
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
) ;
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
) ;
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") ;
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") ;
745 fprintf(fp
,"ENDIF\n") ;
751 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
753 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
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
)
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
] ;
772 strcpy( tmp
, p
->comm_define
) ;
773 strcpy( commuse
, p
->use
) ;
774 t1
= strtok_rentr( tmp
, ";" , &pos1
) ;
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
) ;
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
) ; }
788 strcpy( varname
, t2
) ;
789 strcpy( varref
, t2
) ;
790 if ( q
->node_kind
& FIELD
&& ! (q
->node_kind
& I1
) ) {
791 sprintf(varref
,"grid%%%s",t2
) ;
794 if ( strcmp( q
->type
->name
, "real") && strcmp( q
->type
->name
, "integer") && strcmp( q
->type
->name
, "doubleprecision") ) { ; }
795 else if ( q
->boundary_array
) { ; }
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
)
804 zdex
= get_index_for_coord( q
, COORD_Z
) ;
805 if ( zdex
>=1 && zdex
<= 3 )
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") ;
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") ;
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") ;
828 fprintf(fp
," ENDIF\n") ;
829 fprintf(fp
,"ENDDO\n") ;
833 fprintf(stderr
,"WARNING: %d some dimension info missing for 4d array %s\n",zdex
,t2
) ;
838 set_mem_order( q
, memord
, 3 ) ;
839 if ( q
->ndims
== 3 ) {
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 ) ;
848 char s
[256], e
[256] ;
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") ;
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") ;
863 else if ( dimd
->len_defined_how
== NAMELIST
)
865 if ( !strcmp(dimd
->assoc_nl_var_s
,"1") ) {
867 sprintf(e
,"config_flags%%%s",dimd
->assoc_nl_var_e
) ;
869 sprintf(s
,"config_flags%%%s",dimd
->assoc_nl_var_s
) ;
870 sprintf(e
,"config_flags%%%s",dimd
->assoc_nl_var_e
) ;
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
) ;
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
) ;
884 else if ( dimd
->len_defined_how
== CONSTANT
)
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
) ;
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
) ;
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") ;
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") ;
915 fprintf(fp
,"ENDIF\n") ;
921 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
923 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
928 gen_periods ( char * dirname
, node_t
* periods
)
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
;
941 char varref
[NAMELEN
] ;
942 char * pos1
, * pos2
;
943 char indices
[NAMELEN
], post
[NAMELEN
] ;
950 #define MAX_4DARRAYS 1000
951 char name_4d
[MAX_4DARRAYS
][NAMELEN
] ;
953 if ( dirname
== NULL
) return(1) ;
955 for ( p
= periods
; p
!= NULL
; p
= p
->next
)
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
)
966 fprintf(stderr
,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamecall
) ;
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
)
977 fprintf(stderr
,"WARNING: gen_periods in registry cannot open %s for writing\n",fnamesub
) ;
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
)
988 fprintf(stderr
,"WARNING: gen_periods in registry cannot open %s for writing\n",fname
) ;
991 /* get maximum period width */
993 strcpy( tmp
, p
->comm_define
) ;
994 t1
= strtok_rentr( tmp
, ";" , &pos1
) ;
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
) ;
1004 print_warning(fp
,fname
) ;
1006 fprintf(fp
,"CALL wrf_debug(2,'calling %s')\n",fname
) ;
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 ;
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
)
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
)
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
) ; }
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
) ; }
1035 if ( q
->node_kind
& FOURD
) {
1036 if ( n4d
< MAX_4DARRAYS
) {
1037 strcpy( name_4d
[n4d
], q
->name
) ;
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") ;
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
++ ; }
1061 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
1063 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
1066 fprintf(fp
,"IF ( config_flags%%periodic_x ) THEN\n") ;
1068 /* generate the stencil init statement for X transfer */
1069 fprintf(fp
,"CALL RSL_LITE_INIT_PERIOD ( local_communicator_periodic, %d , &\n",maxperwidth
) ;
1071 fprintf(fp
, " %d &\n", n3dR
) ;
1072 for ( i
= 0 ; i
< n4d
; i
++ ) {
1073 fprintf(fp
," + num_%s &\n", name_4d
[i
] ) ;
1075 fprintf(fp
," , %d, RWORDSIZE, &\n", n2dR
) ;
1077 fprintf(fp
," %d, %d, RWORDSIZE, &\n", n3dR
, n2dR
) ;
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") ;
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
) ;
1097 fprintf(fp
, " %d &\n", n3dR
) ;
1098 for ( i
= 0 ; i
< n4d
; i
++ ) {
1099 fprintf(fp
," + num_%s &\n", name_4d
[i
] ) ;
1101 fprintf(fp
," , %d, RWORDSIZE, &\n", n2dR
) ;
1103 fprintf(fp
," %d, %d, RWORDSIZE, &\n", n3dR
, n2dR
) ;
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") ;
1118 close_the_file(fp
) ;
1124 gen_swaps ( char * dirname
, node_t
* swaps
)
1128 char commname
[NAMELEN
] ;
1129 char fname
[NAMELEN
] ;
1130 char tmp
[NAMELEN
], tmp2
[NAMELEN
], tmp3
[NAMELEN
] ;
1131 char commuse
[NAMELEN
] ;
1134 char * pos1
, * pos2
;
1135 char indices
[NAMELEN
], post
[NAMELEN
] ;
1142 #define MAX_4DARRAYS 1000
1143 char name_4d
[MAX_4DARRAYS
][NAMELEN
] ;
1145 if ( dirname
== NULL
) return(1) ;
1147 for ( p
= swaps
; p
!= NULL
; p
= p
->next
)
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
)
1155 fprintf(stderr
,"WARNING: gen_swaps in registry cannot open %s for writing\n",fname
) ;
1158 print_warning(fp
,fname
) ;
1160 for ( xy
= 0 ; xy
< 2 ; xy
++ ) {
1162 fprintf(fp
,"CALL wrf_debug(2,'calling %s')\n",fname
) ;
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 ;
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
)
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
)
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
) ; }
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
) ; }
1191 if ( q
->node_kind
& FOURD
) {
1192 if ( n4d
< MAX_4DARRAYS
) {
1193 strcpy( name_4d
[n4d
], q
->name
) ;
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") ;
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
++ ; }
1217 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
1219 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
1222 fprintf(fp
,"IF ( config_flags%%swap_%c ) THEN\n",(xy
==1)?'x':'y') ;
1224 /* generate the init statement for X swap */
1225 fprintf(fp
,"CALL RSL_LITE_INIT_SWAP ( local_communicator, %d , &\n", xy
) ;
1227 fprintf(fp
, " %d &\n", n3dR
) ;
1228 for ( i
= 0 ; i
< n4d
; i
++ ) {
1229 fprintf(fp
," + num_%s &\n", name_4d
[i
] ) ;
1231 fprintf(fp
," , %d, RWORDSIZE, &\n", n2dR
) ;
1233 fprintf(fp
," %d, %d, RWORDSIZE, &\n", n3dR
, n2dR
) ;
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" ) ;
1249 fprintf(fp
,"END IF\n") ;
1252 close_the_file(fp
) ;
1258 gen_cycles ( char * dirname
, node_t
* cycles
)
1262 char commname
[NAMELEN
] ;
1263 char fname
[NAMELEN
] ;
1264 char tmp
[NAMELEN
], tmp2
[NAMELEN
], tmp3
[NAMELEN
] ;
1265 char commuse
[NAMELEN
] ;
1268 char * pos1
, * pos2
;
1269 char indices
[NAMELEN
], post
[NAMELEN
] ;
1276 #define MAX_4DARRAYS 1000
1277 char name_4d
[MAX_4DARRAYS
][NAMELEN
] ;
1279 if ( dirname
== NULL
) return(1) ;
1281 for ( p
= cycles
; p
!= NULL
; p
= p
->next
)
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
)
1289 fprintf(stderr
,"WARNING: gen_cycles in registry cannot open %s for writing\n",fname
) ;
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) ; }
1302 print_warning(fp
,fname
) ;
1304 for ( xy
= 0 ; xy
< 2 ; xy
++ ) {
1306 fprintf(fp
,"CALL wrf_debug(2,'calling %s')\n",fname
) ;
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 ;
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
)
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
)
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
) ; }
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
) ; }
1335 if ( q
->node_kind
& FOURD
) {
1336 if ( n4d
< MAX_4DARRAYS
) {
1337 strcpy( name_4d
[n4d
], q
->name
) ;
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") ;
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
++ ; }
1361 t2
= strtok_rentr( NULL
, "," , &pos2
) ;
1363 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
1366 fprintf(fp
,"IF ( config_flags%%cycle_%c ) THEN\n",(xy
==1)?'x':'y') ;
1368 /* generate the init statement for X swap */
1369 fprintf(fp
,"CALL RSL_LITE_INIT_CYCLE ( local_communicator, %d , %d, &\n", xy
, inout
) ;
1371 fprintf(fp
, " %d &\n", n3dR
) ;
1372 for ( i
= 0 ; i
< n4d
; i
++ ) {
1373 fprintf(fp
," + num_%s &\n", name_4d
[i
] ) ;
1375 fprintf(fp
," , %d, RWORDSIZE, &\n", n2dR
) ;
1377 fprintf(fp
," %d, %d, RWORDSIZE, &\n", n3dR
, n2dR
) ;
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" ) ;
1393 fprintf(fp
,"END IF\n") ;
1396 close_the_file(fp
) ;
1402 gen_xposes ( char * dirname
)
1405 char commname
[NAMELEN
] ;
1406 char fname
[NAMELEN
] ;
1407 char tmp
[4096], tmp2
[4096], tmp3
[4096] ;
1408 char commuse
[4096] ;
1411 char * pos1
, * pos2
;
1412 char *xposedir
[] = { "z2x" , "x2z" , "x2y" , "y2x" , "z2y" , "y2z" , 0L } ;
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
] ;
1419 if ( dirname
== NULL
) return(1) ;
1421 for ( p
= Xposes
; p
!= NULL
; p
= p
->next
)
1423 for ( x
= xposedir
; *x
; x
++ )
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
)
1431 fprintf(stderr
,"WARNING: gen_halos in registry cannot open %s for writing\n",fname
) ;
1435 print_warning(fp
,fname
) ;
1437 strcpy( tmp
, p
->comm_define
) ;
1438 strcpy( commuse
, p
->use
) ;
1439 t1
= strtok_rentr( tmp
, ";" , &pos1
) ;
1440 while ( t1
!= NULL
)
1442 strcpy( tmp2
, t1
) ;
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
) ;
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
)
1462 sprintf(indices_z
, "%s",index_with_firstelem("(","",-1,tmp3
,q
,post
)) ;
1464 if ( q
->node_kind
& FOURD
) {
1465 strcat( varref_z
, "(grid%sm31,grid%sm32,grid%sm33,itrace )" ) ;
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
) ;
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
)
1486 sprintf(indices_x
, "%s",index_with_firstelem("(","",-1,tmp3
,q
,post
)) ;
1488 if ( q
->node_kind
& FOURD
) {
1489 strcat( varref_x
, "(grid%sm31x,grid%sm32x,grid%sm33x,itrace )" ) ;
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
) ;
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
)
1510 sprintf(indices_y
, "%s",index_with_firstelem("(","",-1,tmp3
,q
,post
)) ;
1512 if ( q
->node_kind
& FOURD
) {
1513 strcat( varref_y
, "(grid%sm31y,grid%sm32y,grid%sm33y,itrace )" ) ;
1516 t1
= strtok_rentr( NULL
, ";" , &pos1
) ;
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" ) ;
1591 close_the_file(fp
) ;
1600 gen_comm_descrips ( char * dirname
)
1603 char * fn
= "dm_comm_cpp_flags" ;
1604 char commname
[NAMELEN
] ;
1605 char fname
[NAMELEN
] ;
1609 if ( dirname
== NULL
) return(1) ;
1611 if ( strlen(dirname
) > 0 ) { sprintf(fname
,"%s/%s",dirname
,fn
) ; }
1612 else { sprintf(fname
,"%s",fn
) ; }
1614 if ((fp
= fopen( fname
, "w" )) == NULL
)
1616 fprintf(stderr
,"WARNING: gen_comm_descrips in registry cannot open %s for writing\n",fname
) ;
1625 gen_shift ( char * dirname
)
1629 node_t
*p
, *q
, *dimd
;
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
;
1640 for ( direction
= directions
; *direction
!= NULL
; direction
++ )
1642 if ( dirname
== NULL
) return(1) ;
1643 sprintf(fname
,"shift_halo_%s_halo",*direction
) ;
1646 sprintf( Shift
.use
, "" ) ;
1647 strcpy( Shift
.comm_define
, "SHW:" ) ;
1648 strcpy( Shift
.name
, fname
) ;
1650 for ( p
= Domain
.fields
; p
!= NULL
; p
= p
->next
) {
1651 if (( p
->node_kind
& (FIELD
| FOURD
) ) && p
->ndims
>= 2 && ! p
->boundary_array
)
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") ;
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
) ) {
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") ;
1675 if ( p
->type
->type_type
== SIMPLE
)
1677 for ( i
= 1 ; i
<= p
->ntl
; i
++ )
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
, "," ) ;
1688 if ( strlen(Shift
.comm_define
) > 0 )Shift
.comm_define
[strlen(Shift
.comm_define
)-1] = '\0' ;
1691 gen_halos( dirname
, NULL
, &Shift
, 0 ) ;
1693 sprintf(fname
,"%s/shift_halo_%s.inc",dirname
,*direction
) ;
1694 if ((fp
= fopen( fname
, "w" )) == NULL
) return(1) ;
1696 /* now generate the shifts themselves */
1698 for ( p
= Domain
.fields
; p
!= NULL
; p
= p
->next
)
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" ) ) {
1707 /* do not shift transpose variables */
1708 if ( p
->proc_orient
== ALL_X_ON_PROC
|| p
->proc_orient
== ALL_Y_ON_PROC
) continue ;
1710 if (( p
->node_kind
& (FIELD
| FOURD
) ) && p
->ndims
>= 2 && ! p
->boundary_array
)
1713 if ( p
->type
->type_type
== SIMPLE
)
1715 for ( i
= 1 ; i
<= p
->ntl
; i
++ )
1718 if ( p
->ntl
> 1 ) sprintf(vname
,"%s_%d",p
->name
,i
) ;
1719 else sprintf(vname
,"%s",p
->name
) ;
1721 if ( p
->node_kind
& FOURD
)
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 )
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
-- ) {
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
) ;
1740 strcpy(moredims
,"") ;
1741 for ( d
= 3 ; d
< p
->ndims
; d
++ ) {
1742 sprintf(temp
,"idim%d",d
-2) ;
1743 strcat(moredims
,",") ; strcat(moredims
,temp
) ;
1745 strcat(moredims
,",") ;
1746 if ( !strcmp( *direction
, "x" ) )
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") ;
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") ;
1822 for ( d
= p
->ndims
-1; d
>= 3 ; d
-- ) {
1823 fprintf(fp
, " ENDDO\n" ) ;
1825 fprintf(fp
, " ENDDO\n" ) ;
1829 fprintf(stderr
,"WARNING: %d some dimension info missing for 4d array %s\n",zdex
,t2
) ;
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") ;
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") ;
1912 close_the_file(fp
) ;
1917 gen_datacalls ( char * dirname
)
1920 char * fn
= "data_calls.inc" ;
1921 char fname
[NAMELEN
] ;
1923 if ( dirname
== NULL
) return(1) ;
1924 if ( strlen(dirname
) > 0 )
1925 { sprintf(fname
,"%s/%s",dirname
,fn
) ; }
1927 { sprintf(fname
,"%s",fn
) ; }
1928 if ((fp
= fopen( fname
, "w" )) == NULL
) return(1) ;
1929 print_warning(fp
,fname
) ;
1930 close_the_file(fp
) ;
1937 gen_nest_packing ( char * dirname
)
1939 gen_nest_pack( dirname
) ;
1940 gen_nest_unpack( dirname
) ;
1947 gen_nest_pack ( char * dirname
)
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
} ;
1954 char ** fnp
; char * fn
;
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
] ;
1966 for ( fnp
= fnlst
, ipath
= 0 ; *fnp
; fnp
++ , ipath
++ )
1969 if ( dirname
== NULL
) return(1) ;
1970 if ( strlen(dirname
) > 0 ) {
1971 sprintf(fname
,"%s/%s",dirname
,fn
) ;
1973 sprintf(fname
,"%s",fn
) ;
1975 if ((fp
= fopen( fname
, "w" )) == NULL
) return(1) ;
1976 print_warning(fp
,fname
) ;
1980 node
= Domain
.fields
;
1982 count_fields ( node
, &d2
, &d3
, fourd_names
, down_path
[ipath
] ) ;
1984 if ( d2
+ d3
> 0 ) {
1985 if ( down_path
[ipath
] == INTERP_UP
)
1987 info_name
= "rsl_lite_to_parent_info" ;
1992 info_name
= "rsl_lite_to_child_info" ;
1996 fprintf(fp
,"msize = (%d + %s )* nlev + %d\n", d3
, fourd_names
, d2
) ;
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") ;
2009 fprintf(fp
,"DO while ( retval .eq. 1 )\n") ;
2011 gen_nest_packunpack ( fp
, Domain
.fields
, PACKIT
, down_path
[ipath
] ) ;
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") ;
2024 fprintf(fp
,"ENDDO\n") ;
2026 close_the_file(fp
) ;
2032 gen_nest_unpack ( char * dirname
)
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
} ;
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
] ;
2047 char vname
[NAMELEN
] ; char tag
[NAMELEN
] ; char fourd_names
[NAMELEN_LONG
] ;
2050 for ( fnp
= fnlst
, ipath
= 0 ; *fnp
; fnp
++ , ipath
++ )
2055 node
= Domain
.fields
;
2057 if ( dirname
== NULL
) return(1) ;
2058 if ( strlen(dirname
) > 0 )
2059 { sprintf(fname
,"%s/%s",dirname
,fn
) ; }
2061 { sprintf(fname
,"%s",fn
) ; }
2062 if ((fp
= fopen( fname
, "w" )) == NULL
) return(1) ;
2063 print_warning(fp
,fname
) ;
2065 count_fields ( node
, &d2
, &d3
, fourd_names
, down_path
[ipath
] ) ;
2067 if ( d2
+ d3
> 0 && strlen(fourd_names
) > 0 ) {
2068 if ( down_path
[ipath
] == INTERP_UP
)
2070 info_name
= "rsl_lite_from_child_info" ;
2074 info_name
= "rsl_lite_from_parent_info" ;
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") ;
2083 close_the_file(fp
) ;
2089 gen_nest_packunpack ( FILE *fp
, node_t
* node
, int dir
, int down_path
)
2092 node_t
*p
, *p1
, *dim
;
2093 int d2
, d3
, xdex
, ydex
, zdex
;
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
;
2103 for ( p1
= node
; p1
!= NULL
; p1
= p1
->next
)
2106 if ( p1
->node_kind
& FOURD
)
2108 if ( p1
->members
->next
)
2109 nest_mask
= p1
->members
->next
->nest_mask
;
2115 nest_mask
= p1
->nest_mask
;
2119 if ( nest_mask
& down_path
)
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
) ;
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
) ;
2137 if ( down_path
== INTERP_UP
)
2139 c
= ( dir
== PACKIT
)?'n':'p' ;
2140 d
= ( dir
== PACKIT
)?'2':'1' ;
2142 c
= ( dir
== UNPACKIT
)?'n':'p' ;
2143 d
= ( dir
== UNPACKIT
)?'2':'1' ;
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") ;
2151 if ( xdex
== 0 && ydex
== 1 ) sprintf(dexes
,"pig,pjg") ;
2152 if ( ydex
== 0 && xdex
== 1 ) sprintf(dexes
,"pjg,pig") ;
2155 /* construct variable name */
2156 if ( p
->node_kind
& FOURD
)
2158 strcpy(moredims
,"") ;
2159 for ( d1
= 3 ; d1
< p
->ndims
; d1
++ ) {
2160 sprintf(temp
,"idim%d",d1
-2) ;
2161 strcat(moredims
,",") ; strcat(moredims
,temp
) ;
2163 strcat(moredims
,",") ;
2164 sprintf(vname
,"%s%s(%s%sitrace)",p
->name
,tag
,dexes
,moredims
) ;
2168 sprintf(vname
,"%s%s(%s)",p
->name
,tag
,dexes
) ;
2172 if ( p
->node_kind
& FOURD
)
2175 fprintf(fp
,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n", p
->name
) ;
2176 for ( d1
= p
->ndims
-1 ; d1
>= 3 ; d1
-- ) {
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
) ;
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. */
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
) ;
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
) ;
2193 if ( dir
== UNPACKIT
)
2195 if ( down_path
== INTERP_UP
)
2198 if ( !strcmp( p
->interpu_fcn_name
,"nmm_vfeedback") ) sjl
= "_v" ; /* KLUDGE FOR NCEP NESTING 20071217 */
2200 fprintf(fp
,"CALL rsl_lite_from_child_msg(((%s)-(%s)+1)*RWORDSIZE,xv) ;\n",ddim
[zdex
][1], ddim
[zdex
][0] ) ;
2202 fprintf(fp
,"CALL rsl_lite_from_child_msg(RWORDSIZE,xv)\n" ) ;
2204 fprintf(fp
,"IF ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jpe_save, %s, %s ) ) THEN\n",
2206 p
->stag_x
?".TRUE.":".FALSE." ,p
->stag_y
?".TRUE.":".FALSE." ) ;
2208 fprintf(fp
,"DO k = %s,%s\nNEST_INFLUENCE(%s%s,xv(k))\nENDDO\n", ddim
[zdex
][0], ddim
[zdex
][1], grid
, vname
) ;
2210 fprintf(fp
,"NEST_INFLUENCE(%s%s,xv(1))\n", grid
, vname
) ;
2212 fprintf(fp
,"ENDIF\n") ;
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
) ;
2220 fprintf(fp
,"CALL rsl_lite_from_parent_msg(RWORDSIZE,xv)\n%s%s = xv(1)\n", grid
, vname
) ;
2226 if ( down_path
== INTERP_UP
)
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] ) ;
2232 fprintf(fp
,"xv(1)= intermediate_grid%%%s\nCALL rsl_lite_to_parent_msg(RWORDSIZE,xv)\n", vname
) ;
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] ) ;
2241 fprintf(fp
,"xv(1)=%s%s\nCALL rsl_lite_to_child_msg(RWORDSIZE,xv)\n", grid
, vname
) ;
2245 if ( p
->node_kind
& FOURD
)
2247 for ( d1
= p
->ndims
-1 ; d1
>= 3 ; d1
-- ) {
2248 fprintf(fp
,"ENDDO\n") ;
2250 fprintf(fp
,"ENDDO\n") ;
2254 fprintf(fp
,"ENDIF\n") ; /* in_use_for_config */
2264 /* STOPPED HERE -- need to include the extra dimensions in the count */
2267 count_fields ( node_t
* node
, int * d2
, int * d3
, char * fourd_names
, int down_path
)
2271 char temp
[80], r
[10], tx
[80], *colon
;
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
)
2278 if ( p
->node_kind
== FOURD
)
2281 count_fields( p
->members
, d2
, d3
, down_path
) ; /* RECURSE */
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
++ ) {
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
) ;
2293 strcat(fourd_names
,")") ;
2298 if ( p
->nest_mask
& down_path
)
2300 if ( p
->node_kind
== FOURD
)
2301 zdex
= get_index_for_coord( p
->members
, COORD_Z
) ;
2303 zdex
= get_index_for_coord( p
, COORD_Z
) ;
2306 (*d2
)++ ; /* if no zdex then only 2 d */
2308 (*d3
)++ ; /* if has a zdex then 3 d */
2320 gen_debug ( char * dirname
)
2324 node_t
*p
, *q
, *dimd
;
2326 char *directions
[] = { "x", "y", 0L } ;
2327 char fname
[NAMELEN
], vname
[NAMELEN
] ;
2328 char indices
[NAMELEN
], post
[NAMELEN
], tmp3
[NAMELEN
] ;
2334 if ( dirname
== NULL
) return(1) ;
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) ;
2340 /* now generate the shifts themselves */
2341 for ( p
= Domain
.fields
; p
!= NULL
; p
= p
->next
)
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" ) ) {
2351 if (( p
->node_kind
& (FIELD
| FOURD
) ) && p
->ndims
>= 2 && ! p
->boundary_array
)
2354 if ( p
->type
->type_type
== SIMPLE
)
2356 for ( i
= 1 ; i
<= p
->ntl
; i
++ )
2359 if ( p
->ntl
> 1 ) sprintf(vname
,"%s_%d",p
->name
,i
) ;
2360 else sprintf(vname
,"%s",p
->name
) ;
2362 if ( p
->node_kind
& FOURD
)
2366 zdex
= get_index_for_coord( p
, COORD_Z
) ;
2367 if ( zdex
>=1 && zdex
<= 3 && strncmp(vname
,"fdda",4) )
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" ) ;
2375 fprintf(stderr
,"WARNING: %d some dimension info missing for 4d array %s\n",zdex
,t2
) ;
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
) ;
2392 close_the_file(fp
) ;
2399 gen_comms ( char * dirname
)
2402 if ( sw_dm_parallel
)
2403 fprintf(stderr
,"ADVISORY: RSL_LITE version of gen_comms is linked in with registry program.\n") ;
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
) ;
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" ) ;
2423 gen_debug( "inc" ) ;