343
344 INTEGER NOUT
345 parameter(nout=6)
346
347 REAL SFAC
348
349 INTEGER ICASE, INCX, INCY, MODE, N
350 LOGICAL PASS
351
352 COMPLEX CA
353 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
354 + MX, MY
355
356 COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
357 + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
358 + CT8(7,4,4), CTY0(1), CX(7), CX0(1), CX1(7),
359 + CY(7), CY0(1), CY1(7)
360 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
361
362 COMPLEX CDOTC, CDOTU
364
366
367 INTRINSIC abs, min
368
369 COMMON /combla/icase, n, incx, incy, mode, pass
370
371 DATA ca/(0.4e0,-0.7e0)/
372 DATA incxs/1, 2, -2, -1/
373 DATA incys/1, -2, 1, -2/
374 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
375 DATA ns/0, 1, 2, 4/
376 DATA cx1/(0.7e0,-0.8e0), (-0.4e0,-0.7e0),
377 + (-0.1e0,-0.9e0), (0.2e0,-0.8e0),
378 + (-0.9e0,-0.4e0), (0.1e0,0.4e0), (-0.6e0,0.6e0)/
379 DATA cy1/(0.6e0,-0.6e0), (-0.9e0,0.5e0),
380 + (0.7e0,-0.6e0), (0.1e0,-0.5e0), (-0.1e0,-0.2e0),
381 + (-0.5e0,-0.3e0), (0.8e0,-0.7e0)/
382 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
383 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
384 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
385 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
386 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
387 + (0.0e0,0.0e0), (0.32e0,-1.41e0),
388 + (-1.55e0,0.5e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
389 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
390 + (0.32e0,-1.41e0), (-1.55e0,0.5e0),
391 + (0.03e0,-0.89e0), (-0.38e0,-0.96e0),
392 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
393 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
394 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
395 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
396 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
397 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
398 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
399 + (-0.9e0,0.5e0), (0.42e0,-1.41e0), (0.0e0,0.0e0),
400 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
401 + (0.78e0,0.06e0), (-0.9e0,0.5e0),
402 + (0.06e0,-0.13e0), (0.1e0,-0.5e0),
403 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
404 + (0.52e0,-1.51e0)/
405 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
406 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
407 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
408 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
409 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
410 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
411 + (-1.18e0,-0.31e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
412 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
413 + (0.78e0,0.06e0), (-1.54e0,0.97e0),
414 + (0.03e0,-0.89e0), (-0.18e0,-1.31e0),
415 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
416 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
417 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
418 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
419 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
420 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
421 + (0.0e0,0.0e0), (0.32e0,-1.41e0), (-0.9e0,0.5e0),
422 + (0.05e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
423 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.32e0,-1.41e0),
424 + (-0.9e0,0.5e0), (0.05e0,-0.6e0), (0.1e0,-0.5e0),
425 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
426 + (0.32e0,-1.16e0)/
427 DATA ct7/(0.0e0,0.0e0), (-0.06e0,-0.90e0),
428 + (0.65e0,-0.47e0), (-0.34e0,-1.22e0),
429 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
430 + (-0.59e0,-1.46e0), (-1.04e0,-0.04e0),
431 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
432 + (-0.83e0,0.59e0), (0.07e0,-0.37e0),
433 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
434 + (-0.76e0,-1.15e0), (-1.33e0,-1.82e0)/
435 DATA ct6/(0.0e0,0.0e0), (0.90e0,0.06e0),
436 + (0.91e0,-0.77e0), (1.80e0,-0.10e0),
437 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.45e0,0.74e0),
438 + (0.20e0,0.90e0), (0.0e0,0.0e0), (0.90e0,0.06e0),
439 + (-0.55e0,0.23e0), (0.83e0,-0.39e0),
440 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.04e0,0.79e0),
441 + (1.95e0,1.22e0)/
442 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7e0,-0.8e0),
443 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
444 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
445 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
446 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
447 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (-0.9e0,0.5e0),
448 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
449 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
450 + (-0.9e0,0.5e0), (0.7e0,-0.6e0), (0.1e0,-0.5e0),
451 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
452 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7e0,-0.8e0),
453 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
454 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
455 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
456 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
457 + (0.0e0,0.0e0), (0.7e0,-0.6e0), (-0.4e0,-0.7e0),
458 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
459 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.8e0,-0.7e0),
460 + (-0.4e0,-0.7e0), (-0.1e0,-0.2e0),
461 + (0.2e0,-0.8e0), (0.7e0,-0.6e0), (0.1e0,0.4e0),
462 + (0.6e0,-0.6e0)/
463 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7e0,-0.8e0),
464 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
465 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
466 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
467 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
468 + (0.0e0,0.0e0), (-0.9e0,0.5e0), (-0.4e0,-0.7e0),
469 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
470 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.1e0,-0.5e0),
471 + (-0.4e0,-0.7e0), (0.7e0,-0.6e0), (0.2e0,-0.8e0),
472 + (-0.9e0,0.5e0), (0.1e0,0.4e0), (0.6e0,-0.6e0)/
473 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7e0,-0.8e0),
474 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
475 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
476 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
477 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
478 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (0.7e0,-0.6e0),
479 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
480 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
481 + (0.7e0,-0.6e0), (-0.1e0,-0.2e0), (0.8e0,-0.7e0),
482 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
483 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
484 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
485 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
486 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
487 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
488 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.4e0,-0.7e0),
489 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
490 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
491 + (-0.4e0,-0.7e0), (-0.1e0,-0.9e0),
492 + (0.2e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
493 + (0.0e0,0.0e0)/
494 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
495 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
496 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
497 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
498 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
499 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (-0.9e0,0.5e0),
500 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
501 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
502 + (-0.9e0,0.5e0), (-0.9e0,-0.4e0), (0.1e0,-0.5e0),
503 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
504 + (0.7e0,-0.8e0)/
505 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
506 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
507 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
508 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
509 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
510 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (0.7e0,-0.8e0),
511 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
512 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
513 + (-0.9e0,-0.4e0), (-0.1e0,-0.9e0),
514 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
515 + (0.0e0,0.0e0)/
516 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
517 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
518 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
519 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
520 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
521 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.9e0,0.5e0),
522 + (-0.4e0,-0.7e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
523 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
524 + (-0.9e0,0.5e0), (-0.4e0,-0.7e0), (0.1e0,-0.5e0),
525 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
526 + (0.2e0,-0.8e0)/
527 DATA csize1/(0.0e0,0.0e0), (0.9e0,0.9e0),
528 + (1.63e0,1.73e0), (2.90e0,2.78e0)/
529 DATA csize3/(0.0e0,0.0e0), (0.0e0,0.0e0),
530 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
531 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.17e0,1.17e0),
532 + (1.17e0,1.17e0), (1.17e0,1.17e0),
533 + (1.17e0,1.17e0), (1.17e0,1.17e0),
534 + (1.17e0,1.17e0), (1.17e0,1.17e0)/
535 DATA csize2/(0.0e0,0.0e0), (0.0e0,0.0e0),
536 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
537 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.54e0,1.54e0),
538 + (1.54e0,1.54e0), (1.54e0,1.54e0),
539 + (1.54e0,1.54e0), (1.54e0,1.54e0),
540 + (1.54e0,1.54e0), (1.54e0,1.54e0)/
541
542 DO 60 ki = 1, 4
543 incx = incxs(ki)
544 incy = incys(ki)
545 mx = abs(incx)
546 my = abs(incy)
547
548 DO 40 kn = 1, 4
549 n = ns(kn)
550 ksize = min(2,kn)
551 lenx = lens(kn,mx)
552 leny = lens(kn,my)
553
554 DO 20 i = 1, 7
555 cx(i) = cx1(i)
556 cy(i) = cy1(i)
557 20 CONTINUE
558 IF (icase.EQ.1) THEN
559
560 cdot(1) =
cdotc(n,cx,incx,cy,incy)
561 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
562 ELSE IF (icase.EQ.2) THEN
563
564 cdot(1) =
cdotu(n,cx,incx,cy,incy)
565 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
566 ELSE IF (icase.EQ.3) THEN
567
568 CALL caxpy(n,ca,cx,incx,cy,incy)
569 CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
570 ELSE IF (icase.EQ.4) THEN
571
572 CALL ccopy(n,cx,incx,cy,incy)
573 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
574 IF (ki.EQ.1) THEN
575 cx0(1) = (42.0e0,43.0e0)
576 cy0(1) = (44.0e0,45.0e0)
577 IF (n.EQ.0) THEN
578 cty0(1) = cy0(1)
579 ELSE
580 cty0(1) = cx0(1)
581 END IF
582 lincx = incx
583 incx = 0
584 lincy = incy
585 incy = 0
586 CALL ccopy(n,cx0,incx,cy0,incy)
587 CALL ctest(1,cy0,cty0,csize3,1.0e0)
588 incx = lincx
589 incy = lincy
590 END IF
591 ELSE IF (icase.EQ.5) THEN
592
593 CALL cswap(n,cx,incx,cy,incy)
594 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0e0)
595 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
596 ELSE
597 WRITE (nout,*) ' Shouldn''t be here in CHECK2'
598 stop
599 END IF
600
601 40 CONTINUE
602 60 CONTINUE
603 RETURN
604
605
606
subroutine ctest(LEN, CCOMP, CTRUE, CSIZE, SFAC)
complex function cdotc(N, CX, INCX, CY, INCY)
CDOTC
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
complex function cdotu(N, CX, INCX, CY, INCY)
CDOTU