551
552
553
554
555
556
557
558 INTEGER IAM, LDPVAL, LDQVAL, LDVAL, NGRIDS, NMAT, NOUT,
559 $ NPROCS
560 REAL ALPHA
561
562
563 CHARACTER*( * ) SUMMRY
564 LOGICAL LTEST( * )
565 INTEGER CSCXVAL( LDVAL ), CSCYVAL( LDVAL ),
566 $ IMBXVAL( LDVAL ), IMBYVAL( LDVAL ),
567 $ INBXVAL( LDVAL ), INBYVAL( LDVAL ),
568 $ INCXVAL( LDVAL ), INCYVAL( LDVAL ),
569 $ IXVAL( LDVAL ), IYVAL( LDVAL ), JXVAL( LDVAL ),
570 $ JYVAL( LDVAL ), MBXVAL( LDVAL ),
571 $ MBYVAL( LDVAL ), MXVAL( LDVAL ),
572 $ MYVAL( LDVAL ), NBXVAL( LDVAL ),
573 $ NBYVAL( LDVAL ), NVAL( LDVAL ), NXVAL( LDVAL ),
574 $ NYVAL( LDVAL ), PVAL( LDPVAL ), QVAL( LDQVAL ),
575 $ RSCXVAL( LDVAL ), RSCYVAL( LDVAL ), WORK( * )
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768 INTEGER NIN, NSUBS
769 parameter( nin = 11, nsubs = 8 )
770
771
772 LOGICAL LTESTT
773 INTEGER I, ICTXT, J
774
775
776 CHARACTER*7 SNAMET
777 CHARACTER*79 USRINFO
778
779
780 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
781 $ blacs_gridinit, blacs_setup,
icopy, igebr2d,
782 $ igebs2d, sgebr2d, sgebs2d
783
784
786
787
788 CHARACTER*7 SNAMES( NSUBS )
789 COMMON /snamec/snames
790
791
792
793
794
795
796
797 IF( iam.EQ.0 ) THEN
798
799
800
801 OPEN( nin, file='PSBLAS1TIM.dat', status='OLD' )
802 READ( nin, fmt = * ) summry
803 summry = ' '
804
805
806
807 READ( nin, fmt = 9999 ) usrinfo
808
809
810
811 READ( nin, fmt = * ) summry
812 READ( nin, fmt = * ) nout
813 IF( nout.NE.0 .AND. nout.NE.6 )
814 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
815
816
817
818
819
820 READ( nin, fmt = * ) ngrids
821 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
822 WRITE( nout, fmt = 9998 ) 'Grids', ldpval
823 GO TO 100
824 ELSE IF( ngrids.GT.ldqval ) THEN
825 WRITE( nout, fmt = 9998 ) 'Grids', ldqval
826 GO TO 100
827 END IF
828
829
830
831 READ( nin, fmt = * ) ( pval( i ), i = 1, ngrids )
832 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
833
834
835
836 READ( nin, fmt = * ) alpha
837
838
839
840 READ( nin, fmt = * ) nmat
841 IF( nmat.LT.1 .OR. nmat.GT.ldval ) THEN
842 WRITE( nout, fmt = 9998 ) 'Tests', ldval
843 GO TO 100
844 END IF
845
846
847
848 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
849 READ( nin, fmt = * ) ( mxval( i ), i = 1, nmat )
850 READ( nin, fmt = * ) ( nxval( i ), i = 1, nmat )
851 READ( nin, fmt = * ) ( imbxval( i ), i = 1, nmat )
852 READ( nin, fmt = * ) ( inbxval( i ), i = 1, nmat )
853 READ( nin, fmt = * ) ( mbxval( i ), i = 1, nmat )
854 READ( nin, fmt = * ) ( nbxval( i ), i = 1, nmat )
855 READ( nin, fmt = * ) ( rscxval( i ), i = 1, nmat )
856 READ( nin, fmt = * ) ( cscxval( i ), i = 1, nmat )
857 READ( nin, fmt = * ) ( ixval( i ), i = 1, nmat )
858 READ( nin, fmt = * ) ( jxval( i ), i = 1, nmat )
859 READ( nin, fmt = * ) ( incxval( i ), i = 1, nmat )
860 READ( nin, fmt = * ) ( myval( i ), i = 1, nmat )
861 READ( nin, fmt = * ) ( nyval( i ), i = 1, nmat )
862 READ( nin, fmt = * ) ( imbyval( i ), i = 1, nmat )
863 READ( nin, fmt = * ) ( inbyval( i ), i = 1, nmat )
864 READ( nin, fmt = * ) ( mbyval( i ), i = 1, nmat )
865 READ( nin, fmt = * ) ( nbyval( i ), i = 1, nmat )
866 READ( nin, fmt = * ) ( rscyval( i ), i = 1, nmat )
867 READ( nin, fmt = * ) ( cscyval( i ), i = 1, nmat )
868 READ( nin, fmt = * ) ( iyval( i ), i = 1, nmat )
869 READ( nin, fmt = * ) ( jyval( i ), i = 1, nmat )
870 READ( nin, fmt = * ) ( incyval( i ), i = 1, nmat )
871
872
873
874
875 DO 10 i = 1, nsubs
876 ltest( i ) = .false.
877 10 CONTINUE
878 20 CONTINUE
879 READ( nin, fmt = 9996, END = 50 ) SNAMET, ltestt
880 DO 30 i = 1, nsubs
881 IF( snamet.EQ.snames( i ) )
882 $ GO TO 40
883 30 CONTINUE
884
885 WRITE( nout, fmt = 9995 )snamet
886 GO TO 100
887
888 40 CONTINUE
889 ltest( i ) = ltestt
890 GO TO 20
891
892 50 CONTINUE
893
894
895
896 CLOSE ( nin )
897
898
899
900
901 IF( nprocs.LT.1 ) THEN
902 nprocs = 0
903 DO 60 i = 1, ngrids
904 nprocs =
max( nprocs, pval( i )*qval( i ) )
905 60 CONTINUE
906 CALL blacs_setup( iam, nprocs )
907 END IF
908
909
910
911
912 CALL blacs_get( -1, 0, ictxt )
913 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
914
915
916
917 CALL sgebs2d( ictxt, 'All', ' ', 1, 1, alpha, 1 )
918
919 work( 1 ) = ngrids
920 work( 2 ) = nmat
921 CALL igebs2d( ictxt, 'All', ' ', 2, 1, work, 2 )
922
923 i = 1
924 CALL icopy( ngrids, pval, 1, work( i ), 1 )
925 i = i + ngrids
926 CALL icopy( ngrids, qval, 1, work( i ), 1 )
927 i = i + ngrids
928 CALL icopy( nmat, nval, 1, work( i ), 1 )
929 i = i + nmat
930 CALL icopy( nmat, mxval, 1, work( i ), 1 )
931 i = i + nmat
932 CALL icopy( nmat, nxval, 1, work( i ), 1 )
933 i = i + nmat
934 CALL icopy( nmat, imbxval, 1, work( i ), 1 )
935 i = i + nmat
936 CALL icopy( nmat, inbxval, 1, work( i ), 1 )
937 i = i + nmat
938 CALL icopy( nmat, mbxval, 1, work( i ), 1 )
939 i = i + nmat
940 CALL icopy( nmat, nbxval, 1, work( i ), 1 )
941 i = i + nmat
942 CALL icopy( nmat, rscxval, 1, work( i ), 1 )
943 i = i + nmat
944 CALL icopy( nmat, cscxval, 1, work( i ), 1 )
945 i = i + nmat
946 CALL icopy( nmat, ixval, 1, work( i ), 1 )
947 i = i + nmat
948 CALL icopy( nmat, jxval, 1, work( i ), 1 )
949 i = i + nmat
950 CALL icopy( nmat, incxval, 1, work( i ), 1 )
951 i = i + nmat
952 CALL icopy( nmat, myval, 1, work( i ), 1 )
953 i = i + nmat
954 CALL icopy( nmat, nyval, 1, work( i ), 1 )
955 i = i + nmat
956 CALL icopy( nmat, imbyval, 1, work( i ), 1 )
957 i = i + nmat
958 CALL icopy( nmat, inbyval, 1, work( i ), 1 )
959 i = i + nmat
960 CALL icopy( nmat, mbyval, 1, work( i ), 1 )
961 i = i + nmat
962 CALL icopy( nmat, nbyval, 1, work( i ), 1 )
963 i = i + nmat
964 CALL icopy( nmat, rscyval, 1, work( i ), 1 )
965 i = i + nmat
966 CALL icopy( nmat, cscyval, 1, work( i ), 1 )
967 i = i + nmat
968 CALL icopy( nmat, iyval, 1, work( i ), 1 )
969 i = i + nmat
970 CALL icopy( nmat, jyval, 1, work( i ), 1 )
971 i = i + nmat
972 CALL icopy( nmat, incyval, 1, work( i ), 1 )
973 i = i + nmat
974
975 DO 70 j = 1, nsubs
976 IF( ltest( j ) ) THEN
977 work( i ) = 1
978 ELSE
979 work( i ) = 0
980 END IF
981 i = i + 1
982 70 CONTINUE
983 i = i - 1
984 CALL igebs2d( ictxt, 'All', ' ', i, 1, work, i )
985
986
987
988 WRITE( nout, fmt = 9999 )
989 $ 'Level 1 PBLAS timing program.'
990 WRITE( nout, fmt = 9999 ) usrinfo
991 WRITE( nout, fmt = * )
992 WRITE( nout, fmt = 9999 )
993 $ 'Timing of the real single precision '//
994 $ 'Level 1 PBLAS'
995 WRITE( nout, fmt = * )
996 WRITE( nout, fmt = 9999 )
997 $ 'The following parameter values will be used:'
998 WRITE( nout, fmt = * )
999 WRITE( nout, fmt = 9993 ) nmat
1000 WRITE( nout, fmt = 9992 ) ngrids
1001 WRITE( nout, fmt = 9990 )
1002 $
'P', ( pval(i), i = 1,
min(ngrids, 5) )
1003 IF( ngrids.GT.5 )
1004 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 6,
1005 $
min( 10, ngrids ) )
1006 IF( ngrids.GT.10 )
1007 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 11,
1008 $
min( 15, ngrids ) )
1009 IF( ngrids.GT.15 )
1010 $ WRITE( nout, fmt = 9991 ) ( pval(i), i = 16, ngrids )
1011 WRITE( nout, fmt = 9990 )
1012 $
'Q', ( qval(i), i = 1,
min(ngrids, 5) )
1013 IF( ngrids.GT.5 )
1014 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 6,
1015 $
min( 10, ngrids ) )
1016 IF( ngrids.GT.10 )
1017 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 11,
1018 $
min( 15, ngrids ) )
1019 IF( ngrids.GT.15 )
1020 $ WRITE( nout, fmt = 9991 ) ( qval(i), i = 16, ngrids )
1021 WRITE( nout, fmt = 9994 ) alpha
1022 IF( ltest( 1 ) ) THEN
1023 WRITE( nout, fmt = 9989 ) snames( 1 ), ' ... Yes'
1024 ELSE
1025 WRITE( nout, fmt = 9989 ) snames( 1 ), ' ... No '
1026 END IF
1027 DO 80 i = 2, nsubs
1028 IF( ltest( i ) ) THEN
1029 WRITE( nout, fmt = 9988 ) snames( i ), ' ... Yes'
1030 ELSE
1031 WRITE( nout, fmt = 9988 ) snames( i ), ' ... No '
1032 END IF
1033 80 CONTINUE
1034 WRITE( nout, fmt = * )
1035
1036 ELSE
1037
1038
1039
1040 IF( nprocs.LT.1 )
1041 $ CALL blacs_setup( iam, nprocs )
1042
1043
1044
1045
1046 CALL blacs_get( -1, 0, ictxt )
1047 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
1048
1049 CALL sgebr2d( ictxt, 'All', ' ', 1, 1, alpha, 1, 0, 0 )
1050
1051 CALL igebr2d( ictxt, 'All', ' ', 2, 1, work, 2, 0, 0 )
1052 ngrids = work( 1 )
1053 nmat = work( 2 )
1054
1055 i = 2*ngrids + 23*nmat + nsubs
1056 CALL igebr2d( ictxt, 'All', ' ', i, 1, work, i, 0, 0 )
1057
1058 i = 1
1059 CALL icopy( ngrids, work( i ), 1, pval, 1 )
1060 i = i + ngrids
1061 CALL icopy( ngrids, work( i ), 1, qval, 1 )
1062 i = i + ngrids
1063 CALL icopy( nmat, work( i ), 1, nval, 1 )
1064 i = i + nmat
1065 CALL icopy( nmat, work( i ), 1, mxval, 1 )
1066 i = i + nmat
1067 CALL icopy( nmat, work( i ), 1, nxval, 1 )
1068 i = i + nmat
1069 CALL icopy( nmat, work( i ), 1, imbxval, 1 )
1070 i = i + nmat
1071 CALL icopy( nmat, work( i ), 1, inbxval, 1 )
1072 i = i + nmat
1073 CALL icopy( nmat, work( i ), 1, mbxval, 1 )
1074 i = i + nmat
1075 CALL icopy( nmat, work( i ), 1, nbxval, 1 )
1076 i = i + nmat
1077 CALL icopy( nmat, work( i ), 1, rscxval, 1 )
1078 i = i + nmat
1079 CALL icopy( nmat, work( i ), 1, cscxval, 1 )
1080 i = i + nmat
1081 CALL icopy( nmat, work( i ), 1, ixval, 1 )
1082 i = i + nmat
1083 CALL icopy( nmat, work( i ), 1, jxval, 1 )
1084 i = i + nmat
1085 CALL icopy( nmat, work( i ), 1, incxval, 1 )
1086 i = i + nmat
1087 CALL icopy( nmat, work( i ), 1, myval, 1 )
1088 i = i + nmat
1089 CALL icopy( nmat, work( i ), 1, nyval, 1 )
1090 i = i + nmat
1091 CALL icopy( nmat, work( i ), 1, imbyval, 1 )
1092 i = i + nmat
1093 CALL icopy( nmat, work( i ), 1, inbyval, 1 )
1094 i = i + nmat
1095 CALL icopy( nmat, work( i ), 1, mbyval, 1 )
1096 i = i + nmat
1097 CALL icopy( nmat, work( i ), 1, nbyval, 1 )
1098 i = i + nmat
1099 CALL icopy( nmat, work( i ), 1, rscyval, 1 )
1100 i = i + nmat
1101 CALL icopy( nmat, work( i ), 1, cscyval, 1 )
1102 i = i + nmat
1103 CALL icopy( nmat, work( i ), 1, iyval, 1 )
1104 i = i + nmat
1105 CALL icopy( nmat, work( i ), 1, jyval, 1 )
1106 i = i + nmat
1107 CALL icopy( nmat, work( i ), 1, incyval, 1 )
1108 i = i + nmat
1109
1110 DO 90 j = 1, nsubs
1111 IF( work( i ).EQ.1 ) THEN
1112 ltest( j ) = .true.
1113 ELSE
1114 ltest( j ) = .false.
1115 END IF
1116 i = i + 1
1117 90 CONTINUE
1118
1119 END IF
1120
1121 CALL blacs_gridexit( ictxt )
1122
1123 RETURN
1124
1125 100 WRITE( nout, fmt = 9997 )
1126 CLOSE( nin )
1127 IF( nout.NE.6 .AND. nout.NE.0 )
1128 $ CLOSE( nout )
1129 CALL blacs_abort( ictxt, 1 )
1130
1131 stop
1132
1133 9999 FORMAT( a )
1134 9998 FORMAT( ' Number of values of ',5a, ' is less than 1 or greater ',
1135 $ 'than ', i2 )
1136 9997 FORMAT( ' Illegal input in file ',40a,'. Aborting run.' )
1137 9996 FORMAT( a7, l2 )
1138 9995 FORMAT( ' Subprogram name ', a7, ' not recognized',
1139 $ /' ******* TESTS ABANDONED *******' )
1140 9994 FORMAT( 2x, 'Alpha : ', g16.6 )
1141 9993 FORMAT( 2x, 'Number of Tests : ', i6 )
1142 9992 FORMAT( 2x, 'Number of process grids : ', i6 )
1143 9991 FORMAT( 2x, ' : ', 5i6 )
1144 9990 FORMAT( 2x, a1, ' : ', 5i6 )
1145 9989 FORMAT( 2x, 'Routines to be tested : ', a, a8 )
1146 9988 FORMAT( 2x, ' ', a, a8 )
1147
1148
1149
subroutine icopy(n, sx, incx, sy, incy)