?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
added README_changes.txt
[wrffire.git] / wrfv2_fire / external / RSL / RSL / rsl_ioserve.c
blob7c6f5ce175c626fa578b5dceacfc2b5cca9e5927
1 /***********************************************************************
2
3 COPYRIGHT
4
5 The following is a notice of limited availability of the code and
6 Government license and disclaimer which must be included in the
7 prologue of the code and in all source listings of the code.
8
9 Copyright notice
10 (c) 1977 University of Chicago
11
12 Permission is hereby granted to use, reproduce, prepare
13 derivative works, and to redistribute to others at no charge. If
14 you distribute a copy or copies of the Software, or you modify a
15 copy or copies of the Software or any portion of it, thus forming
16 a work based on the Software and make and/or distribute copies of
17 such work, you must meet the following conditions:
18
19 a) If you make a copy of the Software (modified or verbatim)
20 it must include the copyright notice and Government
21 license and disclaimer.
22
23 b) You must cause the modified Software to carry prominent
24 notices stating that you changed specified portions of
25 the Software.
26
27 This software was authored by:
28
29 Argonne National Laboratory
30 J. Michalakes: (630) 252-6646; email: michalak@mcs.anl.gov
31 Mathematics and Computer Science Division
32 Argonne National Laboratory, Argonne, IL 60439
33
34 ARGONNE NATIONAL LABORATORY (ANL), WITH FACILITIES IN THE STATES
35 OF ILLINOIS AND IDAHO, IS OWNED BY THE UNITED STATES GOVERNMENT,
36 AND OPERATED BY THE UNIVERSITY OF CHICAGO UNDER PROVISION OF A
37 CONTRACT WITH THE DEPARTMENT OF ENERGY.
38
39 GOVERNMENT LICENSE AND DISCLAIMER
40
41 This computer code material was prepared, in part, as an account
42 of work sponsored by an agency of the United States Government.
43 The Government is granted for itself and others acting on its
44 behalf a paid-up, nonexclusive, irrevocable worldwide license in
45 this data to reproduce, prepare derivative works, distribute
46 copies to the public, perform publicly and display publicly, and
47 to permit others to do so. NEITHER THE UNITED STATES GOVERNMENT
48 NOR ANY AGENCY THEREOF, NOR THE UNIVERSITY OF CHICAGO, NOR ANY OF
49 THEIR EMPLOYEES, MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR
50 ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY FOR THE ACCURACY,
51 COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, APPARATUS,
52 PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD
53 NOT INFRINGE PRIVATELY OWNED RIGHTS.
54
55 ***************************************************************************/
56
57 #include <stdio.h>
58 #include <stdlib.h>
59 #include "rsl.h"
60
61 #include <sys/types.h>
62 #include <sys/socket.h>
63 #include <netinet/in.h>
64 #include <netdb.h>
65 #include <stdio.h>
66 #include <sys/uio.h>
67 #include <string.h>
68 #ifdef T3D
69 #include <fortran.h>
70 #endif
71
72 static int first_time_through = 1 ;
73
74
75 static char request_buf[ 2048 ] ;
76
77 /* hack for IBM/Chameleon, and other machines/api's that aren't
78 completely competant about flushing FORTRAN I/O before shutting
79 down. We'll do that here, each time a shutdown occurs. That
80 entails keeping track of which files were written to, hence
81 this data structure. */
82
83 #define NUNITS 128
84 static unsigned char unit_written[NUNITS] ;
85
86
87
88 RSL_IOSERVE ()
89 {
90 int *rtype ;
91 int msglen, mtag ;
92 int done, nshutdown ;
93 int i, x ;
94
95 nshutdown = 0 ;
96 done = 0 ;
97
98 for ( i = 0 ; i < NUNITS ; i++ )
99 unit_written[i] = '\0' ;
100
101 while( !done )
102 {
103 msglen = 2048 ;
104 mtag = MSG_MONITOR_REQUEST ;
105 RSL_RECV( request_buf, msglen, mtag ) ;
106 rtype = (int *) request_buf ;
107 switch( *rtype )
108 {
109 case RSL_READ_REQUEST :
110 handle_read_request( request_buf ) ;
111 break ;
112 case RSL_WRITE_REQUEST :
113 handle_write_request( request_buf ) ;
114 break ;
115 case RSL_READ_SPECIAL1 :
116 handle_special1( request_buf ) ;
117 break ;
118 case RSL_READ_SPECIAL2 :
119 handle_special2( request_buf ) ;
120 break ;
121 case RSL_SHUTDOWN_REQUEST :
122 /* last processor causes shutdown */
123 nshutdown++ ;
124 if ( nshutdown == rsl_nproc )
125 done = 1 ;
126 break ;
127 default :
128 sprintf(mess,"rsl_ioserve: monitor received unknown request %d",*rtype) ;
129 RSL_TEST_ERR(1,mess) ;
130 }
131 }
132
133 for ( i = 0 ; i < NUNITS ; i++ )
134 {
135 if ( unit_written[i] != '\0' )
136 {
137 x = i + 1 ;
138 RSL_FUNIT_CLOSE ( &x ) ;
139 }
140 }
141 }
142
143 int
144 handle_read_request( req, resp_me, pbuf_me )
145 rsl_read_req_t * req ;
146 char * resp_me ;
147 char ** pbuf_me ;
148 {
149 int dim, i, k, ig, jg, nelem ;
150 int columnelems, nbytes, typelen, len, cursor ;
151 int P ;
152 int msglen, mtag, mdest ;
153 int mlen, nlen, minelems, majelems ;
154 rsl_read_resp_t resp ;
155 int psize[ RSL_MAXPROC ] ; /* size of messages to each processor */
156 char * rbuf ;
157 char *pbuf ;
158 rsl_point_t *domain ;
159 int nelem_alloc ;
160
161 /* efficiency update from JM, 2002/05/24 */
162 int numpts[RSL_MAXPROC], maxnumpts, iii ;
163 int *iptlst, *jptlst, *ip1, *ip2 ;
164 double *dp1, *dp2 ;
165
166 /* bug fix from AJB; rbuf needs to be as large as the
167 domain size (with padding out to factor of 3 for nest
168 dimensions) or may generate a seg-fault in bcopies below
169 in loop that runs over the mlen/nlen dimensions
170 */
171 /* figure out size of read buffer needed (includes padding) */
172 nelem_alloc = domain_info[req->domain].len_m * domain_info[req->domain].len_n ;
173 switch ( req->iotag )
174 {
175 case IO2D_IJ : break ;
176 case IO2D_JI : break ;
177 case IO3D_IJK : nelem_alloc *= req->glen[2] ; break ;
178 case IO3D_JIK : nelem_alloc *= req->glen[2] ; break ;
179 case IO3D_KIJ : nelem_alloc *= req->glen[0] ; break ;
180 case IO3D_IKJ : nelem_alloc *= req->glen[1] ; break ;
181 }
182 /* figure out number of elements to read into read buffer */
183 nelem = 1 ;
184 for ( dim = 0 ; dim < req->ndim ; dim++ )
185 {
186 nelem *= req->glen[dim] ;
187 }
188 typelen = elemsize( req->type ) ;
189 nbytes = nelem_alloc * typelen ;
190
191 rbuf = RSL_MALLOC( char, nbytes ) ;
192
193 /* call fortran to read a record from the named unit */
194 if ( req->internal )
195 {
196 #ifndef NEC_TUNE
197 bcopy( req->unit_p, rbuf, nbytes ) ;
198 #else
199 copymem( (void *)req->unit_p, typelen, (void *)rbuf, typelen, typelen, nelem_alloc ) ;
200 #endif
201 }
202 else
203 {
204 switch ( req->type )
205 {
206 case RSL_REAL :
207 FORT_REALREAD ( &(req->unit), rbuf, &nelem ) ;
208 break ;
209 case RSL_INTEGER :
210 FORT_INTREAD ( &(req->unit), rbuf, &nelem ) ;
211 break ;
212 #ifndef T3D
213 case RSL_DOUBLE :
214 FORT_DOUBLEREAD ( &(req->unit), rbuf, &nelem ) ;
215 break ;
216 #endif
217 case RSL_COMPLEX :
218 FORT_COMPLEXREAD ( &(req->unit), rbuf, &nelem ) ;
219 break ;
220 case RSL_CHARACTER :
221 FORT_CHARACTERREAD ( &(req->unit), rbuf, &nelem ) ;
222 break ;
223 default :
224 RSL_TEST_WRN(1,"read operation not yet implemented for this data type") ;
225 }
226 }
227 /* global record is now stored -- ship it out */
228 switch ( req->iotag )
229 {
230 case IO2D_IJ :
231 columnelems = 1 ;
232 minelems = req->glen[0] ;
233 majelems = req->glen[1] ;
234 break ;
235 case IO2D_JI :
236 columnelems = 1 ;
237 minelems = req->glen[1] ;
238 majelems = req->glen[0] ;
239 break ;
240 case IO3D_IJK :
241 columnelems = req->glen[2] ;
242 minelems = req->glen[0] ;
243 majelems = req->glen[1] ;
244 break ;
245 case IO3D_JIK :
246 columnelems = req->glen[2] ;
247 minelems = req->glen[1] ;
248 majelems = req->glen[0] ;
249 break ;
250 case IO3D_KIJ :
251 columnelems = req->glen[0] ;
252 minelems = req->glen[1] ;
253 majelems = req->glen[2] ;
254 break ;
255 case IO3D_IKJ :
256 columnelems = req->glen[1] ;
257 minelems = req->glen[0] ;
258 majelems = req->glen[2] ;
259 break ;
260 default:
261 RSL_TEST_ERR(1,"handle_read_request: unknown data tag") ;
262 }
263 /* figure out sizes for each processor */
264 pbuf = NULL ;
265 for ( i = 0 ; i < rsl_nproc_all ; i++ ) /* 95/02/22 */
266 {
267 psize[i] = 0 ;
268 numpts[i] = 0 ;
269 }
270 mlen = domain_info[req->domain].len_m ;
271 nlen = domain_info[req->domain].len_n ;
272 domain = domain_info[req->domain].domain ;
273 for ( jg = 0 ; jg < nlen ; jg++ )
274 {
275 for ( ig = 0 ; ig < mlen ; ig++ )
276 {
277 P = domain[INDEX_2(jg,ig,mlen)].P ; /* 2002/05/24 */
278 psize[P] += columnelems * typelen ; /* 2002/05/24 */
279 if ( P >= 0 && P < rsl_nproc_all ) numpts[P]++ ; /* 2002/05/24 */
280 }
281 }
282 maxnumpts = 0 ; /* 2002/05/24 */
283 for ( i = 0 ; i < rsl_nproc_all ; i++ ) /* 2002/05/24 */
284 { /* 2002/05/24 */
285 if ( maxnumpts < numpts[i] ) maxnumpts = numpts[i] ; /* 2002/05/24 */
286 } /* 2002/05/24 */
287
288 iptlst = RSL_MALLOC( int, rsl_nproc_all * maxnumpts ) ; /* 2002/05/24 */
289 jptlst = RSL_MALLOC( int, rsl_nproc_all * maxnumpts ) ; /* 2002/05/24 */
290 for ( i = 0 ; i < rsl_nproc_all ; i++ ) numpts[i] = 0 ; /* 2002/05/24 */
291 for ( jg = 0 ; jg < nlen ; jg++ ) /* 2002/05/24 */
292 { /* 2002/05/24 */
293 for ( ig = 0 ; ig < mlen ; ig++ ) /* 2002/05/24 */
294 { /* 2002/05/24 */
295 P = domain[INDEX_2(jg,ig,mlen)].P ; /* 2002/05/24 */
296 if ( P >= 0 && P < rsl_nproc_all ) /* 2002/05/24 */
297 { /* 2002/05/24 */
298 iptlst[INDEX_2(P,numpts[P],maxnumpts)] = ig ; /* 2002/05/24 */
299 jptlst[INDEX_2(P,numpts[P],maxnumpts)] = jg ; /* 2002/05/24 */
300 numpts[P]++ ; /* 2002/05/24 */
301 } /* 2002/05/24 */
302 } /* 2002/05/24 */
303 } /* 2002/05/24 */
304
305 for ( P = 0 ; P < rsl_nproc_all ; P++ ) /* 95/02/22 */
306 {
307 len = 0 ;
308 len += psize[P] ;
309 pbuf = RSL_MALLOC( char, len ) ;
310 resp.response_type = RSL_READ_RESPONSE ;
311 resp.sequence = req->sequence ;
312 resp.tofollow = psize[P] ;
313 cursor = 0 ;
314 /*bcopy( &resp, &(pbuf[cursor]), sizeof( resp )) ; cursor += sizeof(resp) ; */
315
316 /* NOTE AND WARNING: this code is quick and dirty and makes the very
317 naive assumption that the data set being read in is point for point
318 with the domain and is dimensioned to be exactly the same size!!!!
319 Only with this assumption can the ig, jg indices into the domain
320 data structure be used in this way as indices into the data. This
321 will work for MM. A more general approach will require modification. */
322
323 #ifndef vpp
324 if ( typelen == sizeof ( int ) ) {
325 for ( iii = 0 ; iii < numpts[P] ; iii++ )
326 {
327 ig = iptlst[INDEX_2(P,iii,maxnumpts)] ;
328 jg = jptlst[INDEX_2(P,iii,maxnumpts)] ;
329 RSL_TEST_ERR( cursor >= len,
330 "something wrong with read request: check glen, llen arrays in call") ;
331 switch ( req->iotag )
332 {
333 case IO2D_IJ :
334 ip1 = (int *) &(rbuf[typelen*(ig+jg*req->glen[0])]) ;
335 ip2 = (int *) &(pbuf[cursor]) ;
336 *ip2 = *ip1 ;
337 cursor += typelen ;
338 break ;
339 case IO2D_JI :
340 ip1 = (int *) &(rbuf[typelen*(jg+ig*req->glen[0])]) ;
341 ip2 = (int *) &(pbuf[cursor]) ;
342 *ip2 = *ip1 ;
343 cursor += typelen ;
344 break ;
345 case IO3D_IJK :
346 k = 0 ;
347 ip1 = (int *) &(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]) ;
348 ip2 = (int *) &(pbuf[cursor]) ;
349 for ( k = 0 ; k < req->glen[2] ; k++ )
350 {
351 *ip2 = *ip1 ;
352 ip1 += req->glen[0] * req->glen[1] ;
353 ip2++ ;
354 }
355 cursor += typelen*req->glen[2] ;
356 break ;
357 case IO3D_JIK :
358 k = 0 ;
359 ip1 = (int *) &(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]) ;
360 ip2 = (int *) &(pbuf[cursor]) ;
361 for ( k = 0 ; k < req->glen[2] ; k++ )
362 {
363 *ip2 = *ip1 ;
364 ip1 += req->glen[0] * req->glen[1] ;
365 ip2++ ;
366 }
367 cursor += typelen*req->glen[2] ;
368 break ;
369 case IO3D_KIJ :
370 k = 0 ;
371 ip1 = (int *) &(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]) ;
372 ip2 = (int *) &(pbuf[cursor]) ;
373 for ( k = 0 ; k < req->glen[0] ; k++ )
374 {
375 *ip2 = *ip1 ;
376 ip1++ ;
377 ip2++ ;
378 }
379 cursor += typelen*req->glen[0] ;
380 break ;
381 case IO3D_IKJ :
382 k = 0 ;
383 ip1 = (int *) &(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]) ;
384 ip2 = (int *) &(pbuf[cursor]) ;
385 for ( k = 0 ; k < req->glen[1] ; k++ )
386 {
387 *ip2 = *ip1 ;
388 ip1 += req->glen[0] ;
389 ip2++ ;
390 }
391 cursor += typelen*req->glen[1] ;
392 break ;
393 }
394 }
395 } else if ( typelen == sizeof ( double ) ) {
396 for ( iii = 0 ; iii < numpts[P] ; iii++ )
397 {
398 ig = iptlst[INDEX_2(P,iii,maxnumpts)] ;
399 jg = jptlst[INDEX_2(P,iii,maxnumpts)] ;
400 RSL_TEST_ERR( cursor >= len,
401 "something wrong with read request: check glen, llen arrays in call") ;
402 switch ( req->iotag )
403 {
404 case IO2D_IJ :
405 dp1 = (double *) &(rbuf[typelen*(ig+jg*req->glen[0])]) ;
406 dp2 = (double *) &(pbuf[cursor]) ;
407 *dp2 = *dp1 ;
408 cursor += typelen ;
409 break ;
410 case IO2D_JI :
411 dp1 = (double *) &(rbuf[typelen*(jg+ig*req->glen[0])]) ;
412 dp2 = (double *) &(pbuf[cursor]) ;
413 *dp2 = *dp1 ;
414 cursor += typelen ;
415 break ;
416 case IO3D_IJK :
417 k = 0 ;
418 dp1 = (double *) &(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]) ;
419 dp2 = (double *) &(pbuf[cursor]) ;
420 for ( k = 0 ; k < req->glen[2] ; k++ )
421 {
422 *dp2 = *dp1 ;
423 dp1 += req->glen[0] * req->glen[1] ;
424 dp2++ ;
425 }
426 cursor += typelen*req->glen[2] ;
427 break ;
428 case IO3D_JIK :
429 k = 0 ;
430 dp1 = (double *) &(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]) ;
431 dp2 = (double *) &(pbuf[cursor]) ;
432 for ( k = 0 ; k < req->glen[2] ; k++ )
433 {
434 *dp2 = *dp1 ;
435 dp1 += req->glen[0] * req->glen[1] ;
436 dp2++ ;
437 }
438 cursor += typelen*req->glen[2] ;
439 break ;
440 case IO3D_KIJ :
441 k = 0 ;
442 dp1 = (double *) &(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]) ;
443 dp2 = (double *) &(pbuf[cursor]) ;
444 for ( k = 0 ; k < req->glen[0] ; k++ )
445 {
446 *dp2 = *dp1 ;
447 dp1++ ;
448 dp2++ ;
449 }
450 cursor += typelen*req->glen[0] ;
451 break ;
452 case IO3D_IKJ :
453 k = 0 ;
454 dp1 = (double *) &(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]) ;
455 dp2 = (double *) &(pbuf[cursor]) ;
456 for ( k = 0 ; k < req->glen[1] ; k++ )
457 {
458 *dp2 = *dp1 ;
459 dp1 += req->glen[0] ;
460 dp2++ ;
461 }
462 cursor += typelen*req->glen[1] ;
463 break ;
464 }
465 }
466 }else{
467 for ( iii = 0 ; iii < numpts[P] ; iii++ )
468 {
469 ig = iptlst[INDEX_2(P,iii,maxnumpts)] ;
470 jg = jptlst[INDEX_2(P,iii,maxnumpts)] ;
471 RSL_TEST_ERR( cursor >= len,
472 "something wrong with read request: check glen, llen arrays in call") ;
473 switch ( req->iotag )
474 {
475 case IO2D_IJ :
476 bcopy(&(rbuf[typelen*(ig+jg*req->glen[0])]),
477 &(pbuf[cursor]),
478 typelen) ;
479 cursor += typelen ;
480 break ;
481 case IO2D_JI :
482 bcopy(&(rbuf[typelen*(jg+ig*req->glen[0])]),
483 &(pbuf[cursor]),
484 typelen) ;
485 cursor += typelen ;
486 break ;
487 case IO3D_IJK :
488 for ( k = 0 ; k < req->glen[2] ; k++ )
489 {
490 bcopy(&(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
491 &(pbuf[cursor]),
492 typelen) ;
493 cursor += typelen ;
494 }
495 break ;
496 case IO3D_JIK :
497 for ( k = 0 ; k < req->glen[2] ; k++ )
498 {
499 bcopy(&(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
500 &(pbuf[cursor]),
501 typelen) ;
502 cursor += typelen ;
503 }
504 break ;
505 case IO3D_KIJ :
506 for ( k = 0 ; k < req->glen[0] ; k++ )
507 {
508 bcopy(&(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
509 &(pbuf[cursor]),
510 typelen) ;
511 cursor += typelen ;
512 }
513 break ;
514 case IO3D_IKJ :
515 for ( k = 0 ; k < req->glen[1] ; k++ )
516 {
517 bcopy(&(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
518 &(pbuf[cursor]),
519 typelen) ;
520 cursor += typelen ;
521 }
522 break ;
523 }
524 }
525 }
526 #else
527 for ( jg = 0 ; jg < nlen ; jg++ )
528 {
529 if ( domain[INDEX_2(jg,0,mlen)].P == P )
530 {
531 switch ( req->iotag )
532 {
533 case IO2D_IJ :
534 if ( req->type == RSL_REAL )
535 {
536 ig = 0 ;
537 VRCOPY (&(rbuf[typelen*(ig+jg*req->glen[0])]),
538 &(pbuf[cursor]),
539 &mlen) ;
540 cursor += typelen*mlen ;
541 }
542 else
543 {
544 for ( ig = 0 ; ig < mlen ; ig++ )
545 {
546 bcopy(&(rbuf[typelen*(ig+jg*req->glen[0])]),
547 &(pbuf[cursor]),
548 typelen) ;
549 cursor += typelen ;
550 }
551 }
552 break ;
553 case IO2D_JI :
554 if ( req->type == RSL_REAL )
555 {
556 for ( ig = 0 ; ig < mlen ; ig++ )
557 {
558 bcopy(&(rbuf[typelen*(jg+ig*req->glen[0])]),
559 &(pbuf[cursor]),
560 typelen) ;
561 cursor += typelen ;
562 }
563 }
564 break ;
565 case IO3D_IJK :
566 if ( req->type == RSL_REAL )
567 {
568 ig = 0 ;
569 for ( k = 0 ; k < req->glen[2] ; k++ )
570 {
571 VRCOPY (&(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
572 &(pbuf[cursor]),
573 &mlen) ;
574 cursor += typelen*mlen ;
575 }
576 }
577 else
578 {
579 for ( k = 0 ; k < req->glen[2] ; k++ )
580 {
581 for ( ig = 0 ; ig < mlen ; ig++ )
582 {
583 bcopy(&(rbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
584 &(pbuf[cursor]),
585 typelen) ;
586 cursor += typelen ;
587 }
588 }
589 }
590 break ;
591 case IO3D_JIK :
592 for ( ig = 0 ; ig < mlen ; ig++ )
593 {
594 for ( k = 0 ; k < req->glen[2] ; k++ )
595 {
596 bcopy(&(rbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
597 &(pbuf[cursor]),
598 typelen) ;
599 cursor += typelen ;
600 }
601 }
602 break ;
603 case IO3D_KIJ :
604 for ( ig = 0 ; ig < mlen ; ig++ )
605 {
606 for ( k = 0 ; k < req->glen[0] ; k++ )
607 {
608 bcopy(&(rbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
609 &(pbuf[cursor]),
610 typelen) ;
611 cursor += typelen ;
612 }
613 }
614 break ;
615 case IO3D_IKJ :
616 for ( ig = 0 ; ig < mlen ; ig++ )
617 {
618 for ( k = 0 ; k < req->glen[1] ; k++ )
619 {
620 bcopy(&(rbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
621 &(pbuf[cursor]),
622 typelen) ;
623 cursor += typelen ;
624 }
625 }
626 break ;
627
628 }
629 }
630 }
631 #endif
632 mdest = rsl_c_comp2phys_proc( P ) ;
633 mtag = MTYPE_FROMTO( MSG_READ_RESPONSE, rsl_myproc, mdest ) ;
634 msglen = sizeof( resp ) ;
635
636 #ifndef T3D
637 { int i, j ;
638 for ( i = 0 ; i < msglen ; i++ )
639 {
640 j = j + pbuf[i] ;
641 }
642 dumdebug(j) ;
643 }
644 #endif
645
646
647 if ( rsl_myproc == mdest )
648 {
649 bcopy( &resp, resp_me, msglen ) ;
650 *pbuf_me = pbuf ;
651 }
652 else
653 {
654 RSL_SEND( &resp, msglen, mtag, mdest ) ;
655 msglen = resp.tofollow ;
656 RSL_SEND( pbuf, msglen, mtag, mdest ) ;
657 RSL_FREE( pbuf ) ;
658 }
659 }
660
661 RSL_FREE (iptlst) ; /* 20020524 */
662 RSL_FREE (jptlst) ; /* 20020524 */
663 RSL_FREE( rbuf ) ;
664 return(0) ;
665 }
666
667 static int wrt_sock_err = 0 ;
668 #ifdef NEC_TUNE
669 static int pndomains_init = 0;
670 static int pndomains[ RSL_MAXPROC ] ; /* Number of domains for each processor */
671 #endif
672
673 int
674 handle_write_request( req, nelem, psize_me, pbuf_me )
675 rsl_write_req_t * req ;
676 int nelem ;
677 int psize_me ;
678 char * pbuf_me ;
679 {
680 int dim, i, k, ig, jg, nbytes ;
681 int columnelems, typelen, len, cursor ;
682 int P ;
683 int minelems, majelems ;
684 int msglen, mtag, mtag2, mdest, mfrom ;
685 int mlen, nlen ;
686 rsl_read_resp_t resp ;
687 int psize[ RSL_MAXPROC ] ; /* size of messages to each processor */
688 float * pr , * qr ;
689 char * wbuf ;
690 char *pbuf ;
691 rsl_point_t *domain ;
692 int is_write, ie_write, js_write, je_write ;
693 int in_write ;
694 #ifdef NEC_TUNE
695 int tcursor ;
696 int j ;
697 #endif
698
699 typelen = elemsize( req->type ) ;
700 nbytes = typelen * nelem ;
701 wbuf = RSL_MALLOC( char, nbytes ) ;
702
703 mlen = domain_info[req->domain].len_m ;
704 nlen = domain_info[req->domain].len_n ;
705 domain = domain_info[req->domain].domain ;
706
707 /* global record is now stored -- ship it out */
708 switch ( req->iotag )
709 {
710 case IO2D_IJ :
711 case IO2D_IJ_RAW :
712 case IO2D_IJ_PORTAL :
713 case IO2D_IJ_88 :
714 columnelems = 1 ;
715 minelems = req->glen[0] ;
716 majelems = req->glen[1] ;
717 break ;
718 case IO2D_JI :
719 case IO2D_JI_RAW :
720 case IO2D_JI_PORTAL :
721 case IO2D_JI_88 :
722 columnelems = 1 ;
723 minelems = req->glen[1] ;
724 majelems = req->glen[0] ;
725 break ;
726 case IO3D_IJK :
727 case IO3D_IJK_RAW :
728 case IO3D_IJK_PORTAL :
729 case IO3D_IJK_88 :
730 columnelems = req->glen[2] ;
731 minelems = req->glen[0] ;
732 majelems = req->glen[1] ;
733 break ;
734 case IO3D_JIK :
735 case IO3D_JIK_RAW :
736 case IO3D_JIK_PORTAL :
737 case IO3D_JIK_88 :
738 columnelems = req->glen[2] ;
739 minelems = req->glen[1] ;
740 majelems = req->glen[0] ;
741 break ;
742 case IO3D_KIJ :
743 columnelems = req->glen[0] ;
744 minelems = req->glen[1] ;
745 majelems = req->glen[2] ;
746 break ;
747 case IO3D_IKJ :
748 columnelems = req->glen[1] ;
749 minelems = req->glen[0] ;
750 majelems = req->glen[2] ;
751 break ;
752 default:
753 RSL_TEST_ERR(1,"handle_write_request: unknown data tag") ;
754 }
755
756 RSL_TEST_ERR( majelems <= 0, "Major dim spec on write is zero or less.") ;
757 RSL_TEST_ERR( minelems <= 0, "Minor dim spec on write is zero or less.") ;
758 if ( majelems > nlen )
759 { sprintf(mess,"Major dim spec on write (%d) greater than global domain defini tion in that dimension (%d)\n",majelems,nlen) ;
760 RSL_TEST_ERR(1,mess) ; }
761 if ( minelems > mlen )
762 { sprintf(mess,"Minor dim spec on write (%d) greater than global domain defini tion in that dimension (%d)\n",minelems,mlen) ;
763 RSL_TEST_ERR(1,mess) ; }
764
765 #if !(defined(NEC_TUNE)) || !(defined(NEC_SINGLENEST))
766 #ifndef NEC_TUNE
767 /* figure out sizes for each processor */
768 pbuf = NULL ;
769 for ( i = 0 ; i < rsl_nproc_all ; i++ ) /* 95/02/22 */
770 {
771 psize[i] = (regular_decomp)?(4*sizeof(int)):0 ;
772 }
773 for ( jg = 0 ; jg < majelems ; jg++ )
774 {
775 for ( ig = 0 ; ig < minelems ; ig++ )
776 {
777 psize[domain[INDEX_2(jg,ig,mlen)].P] += columnelems * typelen ;
778 }
779 }
780 #else
781 pbuf = NULL ;
782 /*
783 NECNOTE:
784 Count the number of domains allocated to each processor.
785 */
786 for ( i = 0 ; i < rsl_nproc_all ; i++ )
787 {
788 pndomains[i] = 0 ;
789 }
790 for ( i = 0 ; i < rsl_nproc_all ; i++ )
791 {
792 j = 0 ;
793 for ( jg = 0 ; jg < majelems ; jg++ )
794 {
795 for ( ig = 0 ; ig < minelems ; ig++ )
796 {
797 if( domain[INDEX_2(jg,ig,mlen)].P == i )
798 {
799 j++ ;
800 }
801 }
802 }
803 pndomains[i] = j ;
804 }
805 for ( i = 0 ; i < rsl_nproc_all ; i++ )
806 {
807 psize[i] = ((regular_decomp)?(4*sizeof(int)):0) + pndomains[i]*columnelems*typelen ;
808 }
809 #endif
810 #else /* !(defined(NEC_TUNE)) || !(defined(NEC_SINGLENEST)) */
811 pbuf = NULL ;
812 if ( ! pndomains_init )
813 {
814 /*
815 NECNOTE:
816 Count the number of domains allocated to each processor.
817 */
818 for ( i = 0 ; i < rsl_nproc_all ; i++ )
819 {
820 pndomains[i] = 0 ;
821 }
822 for ( i = 0 ; i < rsl_nproc_all ; i++ )
823 {
824 j = 0 ;
825 for ( jg = 0 ; jg < majelems ; jg++ )
826 {
827 for ( ig = 0 ; ig < minelems ; ig++ )
828 {
829 if( domain[INDEX_2(jg,ig,mlen)].P == i )
830 {
831 j++ ;
832 }
833 }
834 }
835 pndomains[i] = j ;
836 }
837 }
838 for ( i = 0 ; i < rsl_nproc_all ; i++ )
839 {
840 psize[i] = ((regular_decomp)?(4*sizeof(int)):0) + pndomains[i]*columnelems*typelen ;
841 }
842 #endif /* !(defined(NEC_TUNE)) || !(defined(NEC_SINGLENEST)) */
843
844 for ( P = 0 ; P < rsl_nproc_all ; P++ ) /* 95/02/22 */
845 {
846 cursor = 0 ;
847 mdest = rsl_c_comp2phys_proc( P ) ;
848 if ( rsl_myproc != mdest )
849 {
850 #ifdef RSL_SYNCIO
851 /* send a short "go ahead" message */
852 msglen = 1 ;
853 mfrom = mdest ;
854 mtag2 = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, rsl_myproc, mfrom ) ;
855 RSL_SEND( " ", msglen, mtag2, mfrom ) ;
856 #endif
857 msglen = psize[P] ;
858 pbuf = RSL_MALLOC( char, msglen ) ;
859 mfrom = mdest ;
860 mtag2 = MTYPE_FROMTO( MSG_WRITE_COMPUTE_RESPONSE, mfrom, rsl_myproc ) ;
861 RSL_RECV( pbuf, msglen, mtag2 ) ;
862 }
863 else
864 {
865 sprintf(mess,"psize_me (%d) != psize[P] (%d)", psize_me,psize[P]) ;
866 RSL_TEST_ERR( psize_me != psize[P], mess ) ;
867 msglen = psize_me ;
868 pbuf = pbuf_me ;
869 }
870
871 if ( regular_decomp )
872 {
873
874 bcopy( &(pbuf[cursor]), &is_write, sizeof(int) ) ; cursor += sizeof(int) ;
875 bcopy( &(pbuf[cursor]), &ie_write, sizeof(int) ) ; cursor += sizeof(int) ;
876 bcopy( &(pbuf[cursor]), &js_write, sizeof(int) ) ; cursor += sizeof(int) ;
877 bcopy( &(pbuf[cursor]), &je_write, sizeof(int) ) ; cursor += sizeof(int) ;
878
879 in_write = ie_write - is_write + 1 ;
880
881 for ( jg = js_write ; jg <= je_write ; jg++ )
882 {
883 switch ( req->iotag )
884 {
885 case IO2D_IJ :
886 case IO2D_IJ_RAW :
887 case IO2D_IJ_PORTAL :
888 case IO2D_IJ_88 :
889 if ( req->type == RSL_REAL )
890 {
891 ig = is_write ;
892 VRCOPY ( &(pbuf[cursor]),
893 &(wbuf[typelen*(ig+jg*req->glen[0])]),
894 &in_write ) ;
895 cursor += in_write*typelen ;
896 }
897 else
898 {
899 for ( ig = is_write ; ig <= ie_write ; ig++ )
900 {
901 bcopy(&(pbuf[cursor]),
902 &(wbuf[typelen*(ig+jg*req->glen[0])]),
903 typelen) ;
904 cursor += typelen ;
905 }
906 }
907 break ;
908 case IO2D_JI :
909 case IO2D_JI_RAW :
910 case IO2D_JI_PORTAL :
911 case IO2D_JI_88 :
912 for ( ig = is_write ; ig <= ie_write ; ig++ )
913 {
914 bcopy(&(pbuf[cursor]),
915 &(wbuf[typelen*(jg+ig*req->glen[0])]),
916 typelen) ;
917 cursor += typelen ;
918 }
919 break ;
920 case IO3D_IJK :
921 case IO3D_IJK_RAW :
922 case IO3D_IJK_PORTAL :
923 case IO3D_IJK_88 :
924 if ( req->type == RSL_REAL )
925 {
926 ig = is_write ;
927 for ( k = 0 ; k < req->glen[2] ; k++ ) /* note reversal of i and k on vpp */
928 {
929 VRCOPY ( &(pbuf[cursor]),
930 &(wbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
931 &in_write ) ;
932 cursor += typelen*in_write ;
933 }
934 }
935 else
936 {
937 for ( k = 0 ; k < req->glen[2] ; k++ ) /* note reversal of i and k on vpp */
938 {
939 for ( ig = is_write ; ig <= ie_write ; ig++ )
940 {
941 bcopy(&(pbuf[cursor]),
942 &(wbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
943 typelen) ;
944 cursor += typelen ;
945 }
946 }
947 }
948 break ;
949 case IO3D_JIK :
950 case IO3D_JIK_RAW :
951 case IO3D_JIK_PORTAL :
952 case IO3D_JIK_88 :
953 for ( k = 0 ; k < req->glen[2] ; k++ )
954 {
955 for ( ig = is_write ; ig <= ie_write ; ig++ )
956 {
957 bcopy(&(pbuf[cursor]),
958 &(wbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
959 typelen) ;
960 cursor += typelen ;
961 }
962 }
963 break ;
964 case IO3D_KIJ :
965 for ( ig = is_write ; ig <= ie_write ; ig++ )
966 {
967 for ( k = 0 ; k < req->glen[0] ; k++ )
968 {
969 bcopy(&(pbuf[cursor]),
970 &(wbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
971 typelen) ;
972 cursor += typelen ;
973 }
974 }
975 break ;
976 case IO3D_IKJ :
977 #ifndef NEC_TUNE
978 for ( ig = is_write ; ig <= ie_write ; ig++ )
979 {
980 for ( k = 0 ; k < req->glen[1] ; k++ )
981 {
982 bcopy(&(pbuf[cursor]),
983 &(wbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
984 typelen) ;
985 cursor += typelen ;
986 }
987 }
988 #else
989 for ( k = 0 ; k < req->glen[1] ; k++ )
990 {
991 tcursor = cursor + (k * typelen) ;
992 copymem(&(pbuf[tcursor]), typelen*req->glen[1],
993 &(wbuf[typelen*(is_write+req->glen[0]*(k+jg*req->glen[1]))]), typelen,
994 typelen, ie_write-is_write+1) ;
995 }
996 cursor += (ie_write-is_write+1)*req->glen[1]*typelen ;
997 #endif
998 break ;
999 }
1000 }
1001 }
1002 else
1003 {
1004 for ( jg = 0 ; jg < majelems ; jg++ )
1005 {
1006 for ( ig = 0 ; ig < minelems ; ig++ )
1007 {
1008 if ( domain[INDEX_2(jg,ig,mlen)].P == P )
1009 {
1010 switch ( req->iotag )
1011 {
1012 case IO2D_IJ :
1013 case IO2D_IJ_RAW :
1014 case IO2D_IJ_PORTAL :
1015 case IO2D_IJ_88 :
1016 bcopy(&(pbuf[cursor]),
1017 &(wbuf[typelen*(ig+jg*req->glen[0])]),
1018 typelen) ;
1019 cursor += typelen ;
1020 break ;
1021 case IO2D_JI :
1022 case IO2D_JI_RAW :
1023 case IO2D_JI_PORTAL :
1024 case IO2D_JI_88 :
1025 bcopy(&(pbuf[cursor]),
1026 &(wbuf[typelen*(jg+ig*req->glen[0])]),
1027 typelen) ;
1028 cursor += typelen ;
1029 break ;
1030 case IO3D_IJK :
1031 case IO3D_IJK_RAW :
1032 case IO3D_IJK_PORTAL :
1033 case IO3D_IJK_88 :
1034 for ( k = 0 ; k < req->glen[2] ; k++ )
1035 {
1036 bcopy(&(pbuf[cursor]),
1037 &(wbuf[typelen*(ig+req->glen[0]*(jg+k*req->glen[1]))]),
1038 typelen) ;
1039 cursor += typelen ;
1040 }
1041 break ;
1042 case IO3D_JIK :
1043 case IO3D_JIK_RAW :
1044 case IO3D_JIK_PORTAL :
1045 case IO3D_JIK_88 :
1046 for ( k = 0 ; k < req->glen[2] ; k++ )
1047 {
1048 bcopy(&(pbuf[cursor]),
1049 &(wbuf[typelen*(jg+req->glen[0]*(ig+k*req->glen[1]))]),
1050 typelen) ;
1051 cursor += typelen ;
1052 }
1053 break ;
1054 case IO3D_KIJ :
1055 for ( k = 0 ; k < req->glen[0] ; k++ )
1056 {
1057 bcopy(&(pbuf[cursor]),
1058 &(wbuf[typelen*(k+req->glen[0]*(ig+jg*req->glen[1]))]),
1059 typelen) ;
1060 cursor += typelen ;
1061 }
1062 break ;
1063 case IO3D_IKJ :
1064 for ( k = 0 ; k < req->glen[1] ; k++ )
1065 {
1066 bcopy(&(pbuf[cursor]),
1067 &(wbuf[typelen*(ig+req->glen[0]*(k+jg*req->glen[1]))]),
1068 typelen) ;
1069 cursor += typelen ;
1070 }
1071 break ;
1072
1073 }
1074 }
1075 }
1076 }
1077 }
1078 if ( rsl_myproc != rsl_c_comp2phys_proc( P ) )
1079 {
1080 RSL_FREE( pbuf ) ; /* the monitor frees its own buffer outside
1081 this routine */
1082 }
1083 }
1084
1085 /* mark the unit as needing to be flushed */
1086 if ( ! req->internal )
1087 {
1088 unit_written[ req->unit - 1 ] = (unsigned char) 1 ;
1089 }
1090
1091 /* start 981228 AFWA_IO */
1092 /* need some kind of graceful failure if the node runs out of memory */
1093 if ( rsl_buffer_output && ! req->internal )
1094 {
1095 if ( write_buffer_head == NULL && write_buffer_tail == NULL )
1096 {
1097 write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1098 write_buffer_tail = write_buffer_head ;
1099 }
1100 else
1101 {
1102 write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1103 write_buffer_tail = write_buffer_tail->next ;
1104 }
1105 write_buffer_tail->req = *req ;
1106 write_buffer_tail->nelem = nelem ;
1107 write_buffer_tail->buf = RSL_MALLOC( char, nelem * elemsize( req->type ) ) ;
1108 bcopy( wbuf, write_buffer_tail->buf, nelem * elemsize( req->type ) ) ;
1109 }
1110 else
1111 {
1112 send_to_output_device( req, wbuf, nelem ) ;
1113 }
1114 RSL_FREE( wbuf ) ;
1115 return(0) ;
1116 }
1117
1118
1119 /* these routines added for MM5 v3 */
1120
1121
1122 RSL_WRITE_1D_DATA( unit_p,
1123 buf,
1124 nbuf_p,
1125 type_p )
1126 int_p unit_p ;
1127 char * buf ; int_p nbuf_p ;
1128 int_p type_p ;
1129 {
1130 rsl_write_req_t req ;
1131 int nelem ;
1132 int icurs ;
1133 char * wbuf ;
1134 int i_am_monitor ;
1135 int type, typelen ;
1136
1137 RSL_C_IAMMONITOR( &i_am_monitor ) ;
1138 if ( ! i_am_monitor ) return ;
1139
1140 nelem = *nbuf_p ;
1141 type = *type_p ;
1142 typelen = elemsize( type ) ;
1143
1144 req.internal = 0 ;
1145 req.request_type = RSL_WRITE_REQUEST ;
1146 req.request_mode = MSG_IO_FORTRAN ;
1147 req.unit = *unit_p ;
1148 req.unit_p = unit_p ;
1149 req.iotag = IO_REPL ;
1150 req.type = type ;
1151
1152 wbuf = RSL_MALLOC( char, nelem*typelen ) ;
1153
1154 icurs = 0 ;
1155 bcopy( buf , wbuf, nelem*typelen ) ;
1156
1157 if ( rsl_buffer_output && ! req.internal )
1158 {
1159 if ( write_buffer_head == NULL && write_buffer_tail == NULL )
1160 {
1161 write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1162 write_buffer_tail = write_buffer_head ;
1163 }
1164 else
1165 {
1166 write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1167 write_buffer_tail = write_buffer_tail->next ;
1168 }
1169 write_buffer_tail->req = req ;
1170 write_buffer_tail->nelem = nelem ;
1171 write_buffer_tail->buf = RSL_MALLOC( char, nelem*typelen ) ;
1172 bcopy( wbuf, write_buffer_tail->buf, nelem*typelen ) ;
1173 }
1174 else
1175 {
1176 send_to_output_device( &req, wbuf, nelem ) ;
1177 }
1178
1179 RSL_FREE( wbuf ) ;
1180 }
1181
1182 send_to_output_device( req, wbuf, nelem )
1183 rsl_write_req_t * req ;
1184 char * wbuf ;
1185 int nelem ;
1186 {
1187
1188 int nbytes, typelen, minelems, majelems, columnelems ;
1189 int ig, jg ;
1190
1191 typelen = elemsize( req->type ) ;
1192 nbytes = typelen * nelem ;
1193
1194 /* global record is now stored -- ship it out */
1195 switch ( req->iotag )
1196 {
1197 case IO2D_IJ :
1198 case IO2D_IJ_RAW :
1199 case IO2D_IJ_PORTAL :
1200 case IO2D_IJ_88 :
1201 columnelems = 1 ;
1202 minelems = req->glen[0] ;
1203 majelems = req->glen[1] ;
1204 break ;
1205 case IO2D_JI :
1206 case IO2D_JI_RAW :
1207 case IO2D_JI_PORTAL :
1208 case IO2D_JI_88 :
1209 columnelems = 1 ;
1210 minelems = req->glen[1] ;
1211 majelems = req->glen[0] ;
1212 break ;
1213 case IO3D_IJK :
1214 case IO3D_IJK_RAW :
1215 case IO3D_IJK_PORTAL :
1216 case IO3D_IJK_88 :
1217 columnelems = req->glen[2] ;
1218 minelems = req->glen[0] ;
1219 majelems = req->glen[1] ;
1220 break ;
1221 case IO3D_JIK :
1222 case IO3D_JIK_RAW :
1223 case IO3D_JIK_PORTAL :
1224 case IO3D_JIK_88 :
1225 columnelems = req->glen[2] ;
1226 minelems = req->glen[1] ;
1227 majelems = req->glen[0] ;
1228 break ;
1229 case IO3D_KIJ :
1230 columnelems = req->glen[0] ;
1231 minelems = req->glen[1] ;
1232 majelems = req->glen[2] ;
1233 break ;
1234 case IO3D_IKJ :
1235 columnelems = req->glen[1] ;
1236 minelems = req->glen[0] ;
1237 majelems = req->glen[2] ;
1238 break ;
1239 case IO_REPL :
1240 break ;
1241 default:
1242 RSL_TEST_ERR(1,"handle_write_request: unknown data tag") ;
1243 }
1244
1245 if ( req->request_mode == MSG_IO_FORTRAN )
1246 {
1247
1248 /* call fortran to write a record to the named unit */
1249 if ( req->internal )
1250 {
1251 bcopy( wbuf, req->unit_p, nbytes ) ;
1252 }
1253 else
1254 {
1255 /* call fortran to write a record to the named unit */
1256 switch ( req->type )
1257 {
1258 case RSL_REAL :
1259 FORT_REALWRITE ( &(req->unit), wbuf, &nelem ) ;
1260 break ;
1261 case RSL_INTEGER :
1262 FORT_INTWRITE ( &(req->unit), wbuf, &nelem ) ;
1263 break ;
1264 #ifndef T3D
1265 case RSL_DOUBLE :
1266 FORT_DOUBLEWRITE ( &(req->unit), wbuf, &nelem ) ;
1267 break ;
1268 #endif
1269 case RSL_COMPLEX :
1270 FORT_COMPLEXWRITE ( &(req->unit), wbuf, &nelem ) ;
1271 break ;
1272 case RSL_CHARACTER :
1273 #ifndef T3D
1274 FORT_CHARACTERWRITE ( &(req->unit), wbuf, &nelem ) ;
1275 #else
1276 {
1277 _fcd x ;
1278 x = _cptofcd( wbuf, nelem ) ;
1279 FORT_CHARACTERWRITE ( &(req->unit), x, &nelem ) ;
1280 }
1281 #endif
1282 break ;
1283 default :
1284 RSL_TEST_WRN(1,"write operation not implemented for this data type") ;
1285 }
1286 }
1287 }
1288 else
1289 if ( req->request_mode == MSG_IO_SOCKET )
1290 {
1291 /* nbytes contains the number of bytes to be written,
1292 wbuf is the buffer to be written,
1293 req->unit is the socket id */
1294
1295 int cw ;
1296 struct hdr_info_3d
1297 {
1298 int typelen, xdim, ydim, zdim;
1299 } wbuf_header ;
1300
1301 if ( req->request_mode2 == MSG_MODE2_RAW )
1302 {
1303 if ( write_sock( req->unit, wbuf, nbytes ) < 0 )
1304 {
1305 perror("writing on socket");
1306 RSL_TEST_WRN(1,"") ;
1307 }
1308 }
1309 else
1310 if ( req->request_mode2 == MSG_MODE2_FORTRAN )
1311 {
1312 /* simulate control words at beginning and end */
1313 cw = nbytes ;
1314
1315 if (write_sock(req->unit , &cw, 4) < 0)
1316 {
1317 perror("writing first control word on socket");
1318 RSL_TEST_WRN(1,"") ;
1319 }
1320 if (write_sock(req->unit , wbuf, nbytes ) < 0)
1321 {
1322 perror("writing wbuf on socket");
1323 RSL_TEST_WRN(1,"") ;
1324 }
1325 if (write_sock(req->unit , &cw, 4) < 0)
1326 {
1327 perror("writing second control word on socket");
1328 RSL_TEST_WRN(1,"") ;
1329 }
1330 }
1331 else
1332 if ( req->request_mode2 == MSG_MODE2_PORTAL )
1333 {
1334 wbuf_header.typelen = typelen ;
1335 wbuf_header.xdim = minelems ;
1336 wbuf_header.ydim = majelems ;
1337 wbuf_header.zdim = columnelems ;
1338 if (write_sock(req->unit , &wbuf_header , sizeof( wbuf_header ) ) < 0)
1339 {
1340 perror("writing wbuf header on socket");
1341 RSL_TEST_WRN(1,"") ;
1342 }
1343 if (write_sock(req->unit , wbuf , nbytes ) < 0)
1344 {
1345 perror("writing wbuf header on socket");
1346 RSL_TEST_WRN(1,"") ;
1347 }
1348 }
1349 else
1350 if ( req->request_mode2 == MSG_MODE2_88 )
1351 {
1352 int x,y,z ;
1353 char outline[256] ;
1354 for ( z = 0; z < columnelems ; z++ )
1355 {
1356 sprintf(outline,"%d %d\n",majelems,minelems) ;
1357 if (write_sock(req->unit , outline , strlen( outline ) ) < 0)
1358 {
1359 if ( ! wrt_sock_err )
1360 {
1361 wrt_sock_err = 1 ;
1362 perror("writing wbuf header on socket");
1363 RSL_TEST_WRN(1,"") ;
1364 }
1365 }
1366 else
1367 {
1368 for ( ig = 0 ; ig < minelems ; ig++ )
1369 {
1370 for ( jg = 0 ; jg < majelems ; jg++ )
1371 {
1372 if ( req->type == RSL_REAL )
1373 {
1374 float a ;
1375 bcopy(&(wbuf[typelen*(jg+ig*req->glen[0])]),&a,sizeof(float)) ;
1376 sprintf(outline,"%g\n",a) ;
1377 }
1378 else if ( req->type == RSL_DOUBLE )
1379 {
1380 double a ;
1381 bcopy(&(wbuf[typelen*(jg+ig*req->glen[0])]),&a,sizeof(double)) ;
1382 sprintf(outline,"%g\n",a) ;
1383 }
1384 else if ( req->type == RSL_INTEGER )
1385 {
1386 int a ;
1387 bcopy(&(wbuf[typelen*(jg+ig*req->glen[0])]),&a,sizeof(int)) ;
1388 sprintf(outline,"%d\n",a) ;
1389 }
1390 if (write_sock(req->unit , outline , strlen(outline) ) < 0)
1391 {
1392 if ( ! wrt_sock_err )
1393 {
1394 wrt_sock_err = 1 ;
1395 perror("writing wbuf header on socket");
1396 RSL_TEST_WRN(1,"") ;
1397 }
1398 }
1399 }
1400 }
1401 }
1402 }
1403 }
1404 else
1405 {
1406 sprintf(mess, "Unknown request request_mode2: %d\n",
1407 req->request_mode2 ) ;
1408 RSL_TEST_ERR(1,mess) ;
1409 }
1410 }
1411 else
1412 {
1413 sprintf(mess, "Unknown request request_mode: %d\n",
1414 req->request_mode ) ;
1415 RSL_TEST_ERR(1,mess) ;
1416 }
1417 }
1418
1419 RSL_OUTPUT_BUFFER_WRITE ()
1420 {
1421 int i_am_monitor ;
1422 rsl_write_buffer_struct_t * p, * old ;
1423 RSL_C_IAMMONITOR( &i_am_monitor ) ;
1424
1425 if ( rsl_buffer_output && i_am_monitor && write_buffer_head != NULL )
1426 {
1427 for ( p = write_buffer_head ; p ; )
1428 {
1429 send_to_output_device( &(p->req), p->buf, p->nelem ) ;
1430 RSL_FREE( p->buf ) ;
1431 old = p ;
1432 p = p->next ;
1433 RSL_FREE( old ) ;
1434 }
1435 }
1436 write_buffer_head = NULL ;
1437 write_buffer_tail = NULL ;
1438 }
1439
1440 RSL_OUTPUT_BUFFER_YES ()
1441 {
1442 rsl_buffer_output = 1 ;
1443 }
1444 RSL_OUTPUT_BUFFER_NO ()
1445 {
1446 rsl_buffer_output = 0 ;
1447 }
1448
1449 RSL_IO_NODE_YES ()
1450 {
1451 rsl_io_node = 1 ;
1452 }
1453 RSL_IO_NODE_NO ()
1454 {
1455 rsl_io_node = 0 ;
1456 }
1457
1458
1459
1460 #include <signal.h>
1461
1462 write_sock( sd, buf, n )
1463 int sd ;
1464 char * buf ;
1465 int n ;
1466 {
1467 static int errseen = 0 ;
1468 int todo, n_written ;
1469 char * p ;
1470
1471 signal( SIGPIPE, SIG_IGN ) ; /* if the receiver dies, we should cont */
1472 todo = n ;
1473 p = buf ;
1474 if ( ! errseen )
1475 do {
1476 if ((n_written = write(sd, p, todo)) < 0 )
1477 {
1478 errseen = 1 ;
1479 perror("write_sock") ;
1480 return( n_written ) ;
1481 }
1482 p += n_written ;
1483 todo -= n_written ;
1484 } while ( todo > 0 ) ;
1485 signal( SIGPIPE, SIG_DFL ) ;
1486
1487 return(n) ;
1488 }
1489
1490 /* On vpp from here to remainder of file, we may be bcopying character strings
1491 so undefine the substution to the vector bcopy */
1492 #if defined(vpp) || defined(vpp2)
1493 #undef bcopy
1494 #endif
1495
1496
1497 RSL_WRITE_MM5V3_SM_HEADER( unit_p,ndim_p,
1498 s1_p,s2_p,s3_p,s4_p,
1499 e1_p,e2_p,e3_p,e4_p,
1500 iwordsize_p,
1501 xtime_p,
1502 rwordsize_p,
1503 staggering_p, nstaggering_p,
1504 ordering_p, nordering_p,
1505 current_date_p, ncurrent_date_p,
1506 name_p, nname_p,
1507 units_p, nunits_p,
1508 description_p, ndescription_p )
1509 int_p unit_p ;
1510 int_p ndim_p ;
1511 int_p s1_p, s2_p, s3_p, s4_p ;
1512 int_p e1_p, e2_p, e3_p, e4_p ;
1513 int_p iwordsize_p ;
1514 char * xtime_p ;
1515 int_p rwordsize_p ;
1516 #ifndef T3D
1517 char * staggering_p ; int_p nstaggering_p ;
1518 char * ordering_p ; int_p nordering_p ;
1519 char * current_date_p ; int_p ncurrent_date_p ;
1520 char * name_p ; int_p nname_p ;
1521 char * units_p ; int_p nunits_p ;
1522 char * description_p ; int_p ndescription_p ;
1523 #else
1524 _fcd staggering_p ; int_p nstaggering_p ;
1525 _fcd ordering_p ; int_p nordering_p ;
1526 _fcd current_date_p ; int_p ncurrent_date_p ;
1527 _fcd name_p ; int_p nname_p ;
1528 _fcd units_p ; int_p nunits_p ;
1529 _fcd description_p ; int_p ndescription_p ;
1530 #endif
1531 {
1532 rsl_write_req_t req ;
1533 int nelem ;
1534 int iwordsize ;
1535 int rwordsize ;
1536 int nstringbytes ;
1537 int icurs ;
1538 char * wbuf ;
1539 int i_am_monitor ;
1540
1541 RSL_C_IAMMONITOR( &i_am_monitor ) ;
1542 if ( ! i_am_monitor ) return ;
1543
1544 iwordsize = *iwordsize_p ;
1545 rwordsize = *rwordsize_p ;
1546 nstringbytes = *nstaggering_p+ *nordering_p+ *ncurrent_date_p
1547 + *nname_p+ *nunits_p+ *ndescription_p ;
1548 #ifndef T3D
1549 nelem = 9 * iwordsize + 1 * rwordsize + nstringbytes ;
1550 #else
1551 nelem = 9 * iwordsize/2 + 1 * rwordsize/2 + nstringbytes ;
1552 #endif
1553
1554 req.internal = 0 ;
1555 req.request_type = RSL_WRITE_REQUEST ;
1556 req.request_mode = MSG_IO_FORTRAN ;
1557 req.unit = *unit_p ;
1558 req.unit_p = unit_p ;
1559 req.iotag = IO_REPL ;
1560 req.type = RSL_CHARACTER ;
1561
1562 wbuf = RSL_MALLOC( char, nelem ) ;
1563
1564 icurs = 0 ;
1565 #ifndef T3D
1566 bcopy( ndim_p, &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1567 bcopy( s1_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1568 bcopy( s2_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1569 bcopy( s3_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1570 bcopy( s4_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1571 bcopy( e1_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1572 bcopy( e2_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1573 bcopy( e3_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1574 bcopy( e4_p , &(wbuf[icurs]), iwordsize ) ; icurs += iwordsize ;
1575 # ifdef SWAPBYTES
1576 rsl_swapbytes( wbuf, iwordsize, 9 ) ;
1577 # endif
1578 #else
1579 #ifdef crayx1
1580 { int i ;
1581 #else
1582 { short i ;
1583 #endif
1584 i = *ndim_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1585 i = *s1_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1586 i = *s2_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1587 i = *s3_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1588 i = *s4_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1589 i = *e1_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1590 i = *e2_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1591 i = *e3_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1592 i = *e4_p ; bcopy( &i, &(wbuf[icurs]), iwordsize/2 ) ; icurs += iwordsize/2 ;
1593 }
1594 # ifdef SWAPBYTES
1595 rsl_swapbytes( wbuf, iwordsize/2, 9 ) ;
1596 # endif
1597 #endif
1598
1599 #ifndef T3D
1600 bcopy( xtime_p , &(wbuf[icurs]), rwordsize ) ;
1601 # ifdef SWAPBYTES
1602 rsl_swapbytes( &(wbuf[icurs]), rwordsize, 1 ) ;
1603 # endif
1604 icurs += rwordsize ;
1605 #else
1606 { float x ; double y ;
1607 bcopy( xtime_p, &y, rwordsize ) ;
1608 x = y ;
1609 bcopy( &x , &(wbuf[icurs]), rwordsize/2 ) ;
1610 }
1611 # ifdef SWAPBYTES
1612 rsl_swapbytes( &(wbuf[icurs]), rwordsize/2, 1 ) ;
1613 # endif
1614 icurs += rwordsize/2 ;
1615 #endif
1616
1617 #ifndef T3D
1618 bcopy( staggering_p , &(wbuf[icurs]),
1619 *nstaggering_p ) ; icurs += *nstaggering_p ;
1620 bcopy( ordering_p , &(wbuf[icurs]),
1621 *nordering_p ) ; icurs += *nordering_p ;
1622 bcopy( current_date_p , &(wbuf[icurs]),
1623 *ncurrent_date_p ) ; icurs += *ncurrent_date_p ;
1624 bcopy( name_p , &(wbuf[icurs]),
1625 *nname_p ) ; icurs += *nname_p ;
1626 bcopy( units_p , &(wbuf[icurs]),
1627 *nunits_p ) ; icurs += *nunits_p ;
1628 bcopy( description_p , &(wbuf[icurs]),
1629 *ndescription_p ) ; icurs += *ndescription_p ;
1630 #else
1631 bcopy( _fcdtocp( staggering_p ) , &(wbuf[icurs]),
1632 *nstaggering_p ) ; icurs += *nstaggering_p ;
1633 bcopy( _fcdtocp( ordering_p ) , &(wbuf[icurs]),
1634 *nordering_p ) ; icurs += *nordering_p ;
1635 bcopy( _fcdtocp( current_date_p ), &(wbuf[icurs]),
1636 *ncurrent_date_p ) ; icurs += *ncurrent_date_p ;
1637 bcopy( _fcdtocp( name_p ) , &(wbuf[icurs]),
1638 *nname_p ) ; icurs += *nname_p ;
1639 bcopy( _fcdtocp( units_p ) , &(wbuf[icurs]),
1640 *nunits_p ) ; icurs += *nunits_p ;
1641 bcopy( _fcdtocp( description_p ) , &(wbuf[icurs]),
1642 *ndescription_p ) ; icurs += *ndescription_p ;
1643 #endif
1644
1645 if ( rsl_buffer_output && ! req.internal )
1646 {
1647 if ( write_buffer_head == NULL && write_buffer_tail == NULL )
1648 {
1649 write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1650 write_buffer_tail = write_buffer_head ;
1651 }
1652 else
1653 {
1654 write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1655 write_buffer_tail = write_buffer_tail->next ;
1656 }
1657 write_buffer_tail->req = req ;
1658 write_buffer_tail->nelem = nelem ;
1659 write_buffer_tail->buf = RSL_MALLOC( char, nelem ) ;
1660 bcopy( wbuf, write_buffer_tail->buf, nelem ) ;
1661 }
1662 else
1663 {
1664 send_to_output_device( &req, wbuf, nelem ) ;
1665 }
1666
1667 RSL_FREE( wbuf ) ;
1668 }
1669
1670 rsl_swapbytes ( buf, wordsz, nwords )
1671 char * buf ;
1672 int wordsz, nwords ;
1673 {
1674 char tbuf[8] ;
1675 int i ;
1676
1677 if ( wordsz == 4 )
1678 {
1679 for ( i = 0 ; i < nwords*wordsz ; i += wordsz )
1680 {
1681 tbuf[0] = buf[3+i] ;
1682 tbuf[1] = buf[2+i] ;
1683 tbuf[2] = buf[1+i] ;
1684 tbuf[3] = buf[0+i] ;
1685 buf[0+i] = tbuf[0] ;
1686 buf[1+i] = tbuf[1] ;
1687 buf[2+i] = tbuf[2] ;
1688 buf[3+i] = tbuf[3] ;
1689 }
1690 }
1691 else if ( wordsz == 8 )
1692 {
1693 for ( i = 0 ; i < nwords*wordsz ; i += wordsz )
1694 {
1695 tbuf[0] = buf[7+i] ;
1696 tbuf[1] = buf[6+i] ;
1697 tbuf[2] = buf[5+i] ;
1698 tbuf[3] = buf[4+i] ;
1699 tbuf[4] = buf[3+i] ;
1700 tbuf[5] = buf[2+i] ;
1701 tbuf[6] = buf[1+i] ;
1702 tbuf[7] = buf[0+i] ;
1703 buf[0+i] = tbuf[0] ;
1704 buf[1+i] = tbuf[1] ;
1705 buf[2+i] = tbuf[2] ;
1706 buf[3+i] = tbuf[3] ;
1707 buf[4+i] = tbuf[4] ;
1708 buf[5+i] = tbuf[5] ;
1709 buf[6+i] = tbuf[6] ;
1710 buf[7+i] = tbuf[7] ;
1711 }
1712 }
1713 else
1714 {
1715 sprintf(mess,"invalid argument wordsz = %d",wordsz) ;
1716 RSL_TEST_ERR(1,mess) ;
1717 }
1718 }
1719
1720 RSL_WRITE_MM5V3_BIG_HEADER( unit_p,
1721 ibuf,nibuf_p,
1722 rbuf,nrbuf_p,
1723 cb1,ncb1_p,
1724 cb2,ncb2_p,
1725 iwordsize_p,rwordsize_p )
1726 int_p unit_p ;
1727 char * ibuf ; int_p nibuf_p ;
1728 char * rbuf ; int_p nrbuf_p ;
1729 #ifndef T3D
1730 char * cb1 ; int_p ncb1_p ;
1731 char * cb2 ; int_p ncb2_p ;
1732 #else
1733 _fcd cb1 ; int_p ncb1_p ;
1734 _fcd cb2 ; int_p ncb2_p ;
1735 #endif
1736 int_p iwordsize_p ;
1737 int_p rwordsize_p ;
1738 {
1739 rsl_write_req_t req ;
1740 int nelem ;
1741 int iwordsize ;
1742 int rwordsize ;
1743 int nstringbytes ;
1744 int icurs ;
1745 char * wbuf ;
1746 int i_am_monitor ;
1747
1748 RSL_C_IAMMONITOR( &i_am_monitor ) ;
1749 if ( ! i_am_monitor ) return ;
1750
1751 iwordsize = *iwordsize_p ;
1752 rwordsize = *rwordsize_p ;
1753
1754 #ifndef T3D
1755 nelem = *nibuf_p * iwordsize +
1756 *nrbuf_p * rwordsize +
1757 *ncb1_p + *ncb2_p ;
1758 #else
1759 nelem = *nibuf_p * iwordsize /2 +
1760 *nrbuf_p * rwordsize /2 +
1761 *ncb1_p + *ncb2_p ;
1762 #endif
1763
1764 req.internal = 0 ;
1765 req.request_type = RSL_WRITE_REQUEST ;
1766 req.request_mode = MSG_IO_FORTRAN ;
1767 req.unit = *unit_p ;
1768 req.unit_p = unit_p ;
1769 req.iotag = IO_REPL ;
1770 req.type = RSL_CHARACTER ;
1771
1772 wbuf = RSL_MALLOC( char, nelem ) ;
1773
1774 icurs = 0 ;
1775 #ifdef SWAPBYTES
1776 rsl_swapbytes( ibuf, iwordsize, *nibuf_p ) ;
1777 #endif
1778 #ifndef T3D
1779 bcopy( ibuf , &(wbuf[icurs]), *nibuf_p * iwordsize ) ;
1780 icurs += *nibuf_p * iwordsize ;
1781 #else
1782 #ifdef crayx1
1783 { long *p ; int *q ; int i ;
1784 p = (long *) ibuf ;
1785 q = (int *) ibuf ;
1786 #else
1787 { long *p ; short *q ; int i ;
1788 p = (long *) ibuf ;
1789 q = (short *) ibuf ;
1790 #endif
1791 for ( i = 0 ; i < *nibuf_p ; i++ )
1792 {
1793 *q = *p ; q++ ; p++ ;
1794 }
1795 }
1796 bcopy( ibuf , &(wbuf[icurs]), *nibuf_p * iwordsize /2 ) ;
1797 icurs += *nibuf_p * iwordsize / 2 ;
1798 #endif
1799 #ifdef SWAPBYTES
1800 rsl_swapbytes( rbuf, rwordsize, *nrbuf_p ) ;
1801 #endif
1802 #ifndef T3D
1803 bcopy( rbuf , &(wbuf[icurs]), *nrbuf_p * rwordsize ) ;
1804 icurs += *nrbuf_p * rwordsize ;
1805 #else
1806 { double *p ; float *q ; int i ;
1807 p = (double *) rbuf ;
1808 q = (float *) rbuf ;
1809 for ( i = 0 ; i < *nrbuf_p ; i++ )
1810 {
1811 *q = *p ; q++ ; p++ ;
1812 }
1813 }
1814 bcopy( rbuf , &(wbuf[icurs]), *nrbuf_p * rwordsize /2 ) ;
1815 icurs += *nrbuf_p * rwordsize / 2 ;
1816 #endif
1817 #ifndef T3D
1818 bcopy( cb1 , &(wbuf[icurs]), *ncb1_p ) ; icurs += *ncb1_p ;
1819 bcopy( cb2 , &(wbuf[icurs]), *ncb2_p ) ; icurs += *ncb2_p ;
1820 #else
1821 bcopy( _fcdtocp( cb1 ), &(wbuf[icurs]), *ncb1_p ) ; icurs += *ncb1_p ;
1822 bcopy( _fcdtocp( cb2 ), &(wbuf[icurs]), *ncb2_p ) ; icurs += *ncb2_p ;
1823 #endif
1824 if ( rsl_buffer_output && ! req.internal )
1825 {
1826 if ( write_buffer_head == NULL && write_buffer_tail == NULL )
1827 {
1828 write_buffer_head = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1829 write_buffer_tail = write_buffer_head ;
1830 }
1831 else
1832 {
1833 write_buffer_tail->next = RSL_MALLOC( rsl_write_buffer_struct_t, 1 ) ;
1834 write_buffer_tail = write_buffer_tail->next ;
1835 }
1836 write_buffer_tail->req = req ;
1837 write_buffer_tail->nelem = nelem ;
1838 write_buffer_tail->buf = RSL_MALLOC( char, nelem ) ;
1839 bcopy( wbuf, write_buffer_tail->buf, nelem ) ;
1840 }
1841 else
1842 {
1843 send_to_output_device( &req, wbuf, nelem ) ;
1844 }
1845 RSL_FREE( wbuf ) ;
1846 }
A coupled weather-fire forecasting model built on top of Weather Research and Forecasting (WRF).