393
394 INTEGER NOUT
395 parameter(nout=6)
396
397 DOUBLE PRECISION SFAC
398
399 INTEGER ICASE, INCX, INCY, MODE, N
400 LOGICAL PASS
401
402 DOUBLE PRECISION SC, SS
403 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
404
405 DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
406 + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
407 + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
408 + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
409 + SY(7)
410 INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
411 + MWPINY(11), MWPN(11), NS(4)
412
413 EXTERNAL stest,drottest
414
415 INTRINSIC abs, min
416
417 COMMON /combla/icase, n, incx, incy, mode, pass
418
419 DATA incxs/1, 2, -2, -1/
420 DATA incys/1, -2, 1, -2/
421 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
422 DATA ns/0, 1, 2, 4/
423 DATA dx1/0.6d0, 0.1d0, -0.5d0, 0.8d0, 0.9d0, -0.3d0,
424 + -0.4d0/
425 DATA dy1/0.5d0, -0.9d0, 0.3d0, 0.7d0, -0.6d0, 0.2d0,
426 + 0.8d0/
427 DATA sc, ss/0.8d0, 0.6d0/
428 DATA dt9x/0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
429 + 0.0d0, 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
430 + 0.0d0, 0.0d0, 0.78d0, -0.46d0, 0.0d0, 0.0d0,
431 + 0.0d0, 0.0d0, 0.0d0, 0.78d0, -0.46d0, -0.22d0,
432 + 1.06d0, 0.0d0, 0.0d0, 0.0d0, 0.6d0, 0.0d0,
433 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.78d0,
434 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
435 + 0.66d0, 0.1d0, -0.1d0, 0.0d0, 0.0d0, 0.0d0,
436 + 0.0d0, 0.96d0, 0.1d0, -0.76d0, 0.8d0, 0.90d0,
437 + -0.3d0, -0.02d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0,
438 + 0.0d0, 0.0d0, 0.0d0, 0.78d0, 0.0d0, 0.0d0,
439 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, -0.06d0, 0.1d0,
440 + -0.1d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.90d0,
441 + 0.1d0, -0.22d0, 0.8d0, 0.18d0, -0.3d0, -0.02d0,
442 + 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
443 + 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
444 + 0.0d0, 0.78d0, 0.26d0, 0.0d0, 0.0d0, 0.0d0,
445 + 0.0d0, 0.0d0, 0.78d0, 0.26d0, -0.76d0, 1.12d0,
446 + 0.0d0, 0.0d0, 0.0d0/
447 DATA dt9y/0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
448 + 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
449 + 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.0d0, 0.0d0,
450 + 0.0d0, 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.54d0,
451 + 0.08d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,
452 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.04d0,
453 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.7d0,
454 + -0.9d0, -0.12d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
455 + 0.64d0, -0.9d0, -0.30d0, 0.7d0, -0.18d0, 0.2d0,
456 + 0.28d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
457 + 0.0d0, 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0,
458 + 0.0d0, 0.0d0, 0.0d0, 0.7d0, -1.08d0, 0.0d0,
459 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.64d0, -1.26d0,
460 + 0.54d0, 0.20d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0,
461 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
462 + 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
463 + 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.0d0, 0.0d0,
464 + 0.0d0, 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.7d0,
465 + -0.18d0, 0.2d0, 0.16d0/
466 DATA ssize2/0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
467 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
468 + 0.0d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
469 + 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
470 + 1.17d0, 1.17d0, 1.17d0/
471
472
473 DO 60 ki = 1, 4
474 incx = incxs(ki)
475 incy = incys(ki)
476 mx = abs(incx)
477 my = abs(incy)
478
479 DO 40 kn = 1, 4
480 n = ns(kn)
481 ksize = min(2,kn)
482 lenx = lens(kn,mx)
483 leny = lens(kn,my)
484
485 IF (icase.EQ.4) THEN
486
487 DO 20 i = 1, 7
488 sx(i) = dx1(i)
489 sy(i) = dy1(i)
490 stx(i) = dt9x(i,kn,ki)
491 sty(i) = dt9y(i,kn,ki)
492 20 CONTINUE
493 CALL drottest(n,sx,incx,sy,incy,sc,ss)
494 CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
495 CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
496 ELSE
497 WRITE (nout,*) ' Shouldn''t be here in CHECK3'
498 stop
499 END IF
500 40 CONTINUE
501 60 CONTINUE
502
503 mwpc(1) = 1
504 DO 80 i = 2, 11
505 mwpc(i) = 0
506 80 CONTINUE
507 mwps(1) = 0.0
508 DO 100 i = 2, 6
509 mwps(i) = 1.0
510 100 CONTINUE
511 DO 120 i = 7, 11
512 mwps(i) = -1.0
513 120 CONTINUE
514 mwpinx(1) = 1
515 mwpinx(2) = 1
516 mwpinx(3) = 1
517 mwpinx(4) = -1
518 mwpinx(5) = 1
519 mwpinx(6) = -1
520 mwpinx(7) = 1
521 mwpinx(8) = 1
522 mwpinx(9) = -1
523 mwpinx(10) = 1
524 mwpinx(11) = -1
525 mwpiny(1) = 1
526 mwpiny(2) = 1
527 mwpiny(3) = -1
528 mwpiny(4) = -1
529 mwpiny(5) = 2
530 mwpiny(6) = 1
531 mwpiny(7) = 1
532 mwpiny(8) = -1
533 mwpiny(9) = -1
534 mwpiny(10) = 2
535 mwpiny(11) = 1
536 DO 140 i = 1, 11
537 mwpn(i) = 5
538 140 CONTINUE
539 mwpn(5) = 3
540 mwpn(10) = 3
541 DO 160 i = 1, 5
542 mwpx(i) = i
543 mwpy(i) = i
544 mwptx(1,i) = i
545 mwpty(1,i) = i
546 mwptx(2,i) = i
547 mwpty(2,i) = -i
548 mwptx(3,i) = 6 - i
549 mwpty(3,i) = i - 6
550 mwptx(4,i) = i
551 mwpty(4,i) = -i
552 mwptx(6,i) = 6 - i
553 mwpty(6,i) = i - 6
554 mwptx(7,i) = -i
555 mwpty(7,i) = i
556 mwptx(8,i) = i - 6
557 mwpty(8,i) = 6 - i
558 mwptx(9,i) = -i
559 mwpty(9,i) = i
560 mwptx(11,i) = i - 6
561 mwpty(11,i) = 6 - i
562 160 CONTINUE
563 mwptx(5,1) = 1
564 mwptx(5,2) = 3
565 mwptx(5,3) = 5
566 mwptx(5,4) = 4
567 mwptx(5,5) = 5
568 mwpty(5,1) = -1
569 mwpty(5,2) = 2
570 mwpty(5,3) = -2
571 mwpty(5,4) = 4
572 mwpty(5,5) = -3
573 mwptx(10,1) = -1
574 mwptx(10,2) = -3
575 mwptx(10,3) = -5
576 mwptx(10,4) = 4
577 mwptx(10,5) = 5
578 mwpty(10,1) = 1
579 mwpty(10,2) = 2
580 mwpty(10,3) = 2
581 mwpty(10,4) = 4
582 mwpty(10,5) = 3
583 DO 200 i = 1, 11
584 incx = mwpinx(i)
585 incy = mwpiny(i)
586 DO 180 k = 1, 5
587 copyx(k) = mwpx(k)
588 copyy(k) = mwpy(k)
589 mwpstx(k) = mwptx(i,k)
590 mwpsty(k) = mwpty(i,k)
591 180 CONTINUE
592 CALL drottest(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
593 CALL stest(5,copyx,mwpstx,mwpstx,sfac)
594 CALL stest(5,copyy,mwpsty,mwpsty,sfac)
595 200 CONTINUE
596 RETURN
subroutine stest(len, scomp, strue, ssize, sfac)
1.9.7