LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ check3()

subroutine check3 ( real  sfac)

Definition at line 392 of file c_sblat1.f.

393* .. Parameters ..
394 INTEGER NOUT
395 parameter(nout=6)
396* .. Scalar Arguments ..
397 REAL SFAC
398* .. Scalars in Common ..
399 INTEGER ICASE, INCX, INCY, MODE, N
400 LOGICAL PASS
401* .. Local Scalars ..
402 REAL SC, SS
403 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
404* .. Local Arrays ..
405 REAL 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* .. External Subroutines ..
413 EXTERNAL srottest, stest
414* .. Intrinsic Functions ..
415 INTRINSIC abs, min
416* .. Common blocks ..
417 COMMON /combla/icase, n, incx, incy, mode, pass
418* .. Data statements ..
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.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
424 + -0.4e0/
425 DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
426 + 0.8e0/
427 DATA sc, ss/0.8e0, 0.6e0/
428 DATA dt9x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
429 + 0.0e0, 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
430 + 0.0e0, 0.0e0, 0.78e0, -0.46e0, 0.0e0, 0.0e0,
431 + 0.0e0, 0.0e0, 0.0e0, 0.78e0, -0.46e0, -0.22e0,
432 + 1.06e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
433 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.78e0,
434 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
435 + 0.66e0, 0.1e0, -0.1e0, 0.0e0, 0.0e0, 0.0e0,
436 + 0.0e0, 0.96e0, 0.1e0, -0.76e0, 0.8e0, 0.90e0,
437 + -0.3e0, -0.02e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
438 + 0.0e0, 0.0e0, 0.0e0, 0.78e0, 0.0e0, 0.0e0,
439 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.06e0, 0.1e0,
440 + -0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.90e0,
441 + 0.1e0, -0.22e0, 0.8e0, 0.18e0, -0.3e0, -0.02e0,
442 + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
443 + 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
444 + 0.0e0, 0.78e0, 0.26e0, 0.0e0, 0.0e0, 0.0e0,
445 + 0.0e0, 0.0e0, 0.78e0, 0.26e0, -0.76e0, 1.12e0,
446 + 0.0e0, 0.0e0, 0.0e0/
447 DATA dt9y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
448 + 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
449 + 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.0e0, 0.0e0,
450 + 0.0e0, 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.54e0,
451 + 0.08e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
452 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.04e0,
453 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
454 + -0.9e0, -0.12e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
455 + 0.64e0, -0.9e0, -0.30e0, 0.7e0, -0.18e0, 0.2e0,
456 + 0.28e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
457 + 0.0e0, 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0,
458 + 0.0e0, 0.0e0, 0.0e0, 0.7e0, -1.08e0, 0.0e0,
459 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.64e0, -1.26e0,
460 + 0.54e0, 0.20e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0,
461 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
462 + 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
463 + 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.0e0, 0.0e0,
464 + 0.0e0, 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.7e0,
465 + -0.18e0, 0.2e0, 0.16e0/
466 DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
467 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
468 + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
469 + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
470 + 1.17e0, 1.17e0, 1.17e0/
471* .. Executable Statements ..
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* .. SROTTEST ..
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 srottest(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
508 DO 100 i = 2, 6
509 mwps(i) = 1
510 100 CONTINUE
511 DO 120 i = 7, 11
512 mwps(i) = -1
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 srottest(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
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition cblat1.f:614
Here is the call graph for this function: