LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
subroutine check3 ( real  SFAC)

Definition at line 393 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:564

Here is the call graph for this function: