Context Navigation

← Previous Revision
Latest Revision
Next Revision →
Blame
Revision Log

gen_comms.c @ 3933

Last change on this file since 3933 was 2759, checked in by aslmd, 4 years ago
adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 90.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/WRF.COMMON/WRFV3/external/RSL_LITE/gen_comms.c @ 3933

Download in other formats: