869
870
871
872
873
874
875
876 INTEGER IA, JA, M, N
877
878
879 INTEGER DESCA( * ), IPIV( * )
880 REAL A( * )
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979 INTEGER BLOCK_CYCLIC_2D, CSRC_, CTXT_, DLEN_, DTYPE_,
980 $ LLD_, MB_, M_, NB_, N_, RSRC_
981 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
982 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
983 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
984
985
986 INTEGER IACOL, ICOFFA, ICTXT, IITMP, IPVT, IPCOL,
987 $ IPROW, ITMP, J, JJ, JJA, KK, MYCOL, MYROW,
988 $ NPCOL, NPROW, NQ
989
990
991 EXTERNAL blacs_gridinfo, igebr2d, igebs2d, igerv2d,
992 $ igesd2d, igamn2d,
infog1l, psswap
993
994
995 INTEGER INDXL2G, NUMROC
997
998
1000
1001
1002
1003
1004
1005 ictxt = desca( ctxt_ )
1006 CALL blacs_gridinfo( ictxt, nprow, npcol, myrow, mycol )
1007 CALL infog1l( ja, desca( nb_ ), npcol, mycol, desca( csrc_ ), jja,
1008 $ iacol )
1009 icoffa = mod( ja-1, desca( nb_ ) )
1010 nq =
numroc( n+icoffa, desca( nb_ ), mycol, iacol, npcol )
1011 IF( mycol.EQ.iacol )
1012 $ nq = nq - icoffa
1013
1014 DO 20 j = ja, ja+n-2
1015
1016 ipvt = ja+n-1
1017 itmp = ja+n
1018
1019
1020
1021 CALL infog1l( j, desca( nb_ ), npcol, mycol, desca( csrc_ ),
1022 $ jj, iacol )
1023 DO 10 kk = jj, jja+nq-1
1024 IF( ipiv( kk ).LT.ipvt )THEN
1025 iitmp = kk
1026 ipvt = ipiv( kk )
1027 END IF
1028 10 CONTINUE
1029
1030
1031
1032 CALL igamn2d( ictxt, 'Rowwise', ' ', 1, 1, ipvt, 1, iprow,
1033 $ ipcol, 1, -1, mycol )
1034
1035
1036
1037 IF( mycol.EQ.ipcol ) THEN
1038 itmp =
indxl2g( iitmp, desca( nb_ ), mycol, desca( csrc_ ),
1039 $ npcol )
1040 CALL igebs2d( ictxt, 'Rowwise', ' ', 1, 1, itmp, 1 )
1041 IF( ipcol.NE.iacol ) THEN
1042 CALL igerv2d( ictxt, 1, 1, ipiv( iitmp ), 1, myrow,
1043 $ iacol )
1044 ELSE
1045 IF( mycol.EQ.iacol )
1046 $ ipiv( iitmp ) = ipiv( jj )
1047 END IF
1048 ELSE
1049 CALL igebr2d( ictxt, 'Rowwise', ' ', 1, 1, itmp, 1, myrow,
1050 $ ipcol )
1051 IF( mycol.EQ.iacol .AND. ipcol.NE.iacol )
1052 $ CALL igesd2d( ictxt, 1, 1, ipiv( jj ), 1, myrow, ipcol )
1053 END IF
1054
1055
1056
1057 CALL psswap( m, a, ia, itmp, desca, 1, a, ia, j, desca, 1 )
1058
1059 20 CONTINUE
1060
1061
1062
integer function indxl2g(indxloc, nb, iproc, isrcproc, nprocs)
subroutine infog1l(gindx, nb, nprocs, myroc, isrcproc, lindx, rocsrc)
integer function numroc(n, nb, iproc, isrcproc, nprocs)