1C 2C This file is part of MUMPS 5.1.2, released 3C on Mon Oct 2 07:37:01 UTC 2017 4C 5C 6C Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria, 7C University of Bordeaux. 8C 9C This version of MUMPS is provided to you free of charge. It is 10C released under the CeCILL-C license: 11C http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html 12C 13 SUBROUTINE ZMUMPS_COMPACT_FACTORS(A, LDA, NPIV, NBROW, K50, 14 & SIZEA ) 15 IMPLICIT NONE 16 INTEGER LDA, NPIV, NBROW, K50 17 INTEGER(8), INTENT(IN) :: SIZEA 18 COMPLEX(kind=8) A(SIZEA) 19 INTEGER(8) :: IOLD, INEW, J8 20 INTEGER I , ILAST 21 INTEGER NBROW_L_RECTANGLE_TO_MOVE 22 IF ((NPIV.EQ.0).OR.(LDA.EQ.NPIV)) GOTO 500 23 IF ( K50.NE.0 ) THEN 24 IOLD = int(LDA + 1,8) 25 INEW = int(NPIV + 1,8) 26 IF (IOLD .EQ. INEW ) THEN 27 INEW = INEW + int(NPIV,8) * int(NPIV - 1,8) 28 IOLD = IOLD + int(LDA,8) * int(NPIV - 1,8) 29 ELSE 30 DO I = 1, NPIV - 1 31 IF ( I .LE. NPIV-2 ) THEN 32 ILAST = I+1 33 ELSE 34 ILAST = I 35 ENDIF 36 DO J8 = 0_8, int(ILAST,8) 37 A( INEW + J8 ) = A( IOLD + J8 ) 38 END DO 39 INEW = INEW + int(NPIV,8) 40 IOLD = IOLD + int(LDA,8) 41 END DO 42 ENDIF 43 NBROW_L_RECTANGLE_TO_MOVE = NBROW 44 ELSE 45 INEW = 1_8 + int(NPIV,8) * int(LDA + 1,8) 46 IOLD = 1_8 + int(LDA,8) * int(NPIV +1,8) 47 NBROW_L_RECTANGLE_TO_MOVE = NBROW - 1 48 ENDIF 49 DO I = 1, NBROW_L_RECTANGLE_TO_MOVE 50 DO J8 = 0_8, int(NPIV - 1,8) 51 A( INEW + J8 ) = A( IOLD + J8 ) 52 END DO 53 INEW = INEW + int(NPIV,8) 54 IOLD = IOLD + int(LDA,8) 55 ENDDO 56 500 RETURN 57 END SUBROUTINE ZMUMPS_COMPACT_FACTORS 58 SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM(A, LDA, NPIV, NCONTIG, 59 & SIZEA ) 60 IMPLICIT NONE 61 INTEGER, INTENT(IN) :: NCONTIG, NPIV, LDA 62 INTEGER(8), INTENT(IN) :: SIZEA 63 COMPLEX(kind=8), INTENT(INOUT) :: A(SIZEA) 64 INTEGER I, J 65 INTEGER(8) :: INEW, IOLD 66 INEW = int(NPIV+1,8) 67 IOLD = int(LDA+1,8) 68 DO I = 2, NCONTIG 69 DO J = 1, NPIV 70 A(INEW)=A(IOLD) 71 INEW = INEW + 1_8 72 IOLD = IOLD + 1_8 73 ENDDO 74 IOLD = IOLD + int(LDA - NPIV,8) 75 ENDDO 76 RETURN 77 END SUBROUTINE ZMUMPS_COMPACT_FACTORS_UNSYM 78 SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT( A, LA, LDA, POSELT, 79 & IPTRLU, NPIV, 80 & NBCOL_STACK, NBROW_STACK, 81 & NBROW_SEND, SIZECB, KEEP, COMPRESSCB, 82 & LAST_ALLOWED, NBROW_ALREADY_STACKED ) 83 IMPLICIT NONE 84 INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB 85 LOGICAL, intent (in) :: COMPRESSCB 86 COMPLEX(kind=8) A(LA) 87 INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, 88 & NBROW_SEND 89 INTEGER, intent(inout) :: NBROW_ALREADY_STACKED 90 INTEGER(8), intent(in) :: LAST_ALLOWED 91 INTEGER(8) :: APOS, NPOS 92 INTEGER NBROW 93 INTEGER(8) :: J 94 INTEGER I, KEEP(500) 95#if defined(ZERO_TRIANGLE) 96 COMPLEX(kind=8) ZERO 97 PARAMETER( ZERO = (0.0D0,0.0D0) ) 98#endif 99 NBROW = NBROW_STACK + NBROW_SEND 100 IF (NBROW_STACK .NE. 0 ) THEN 101 NPOS = IPTRLU + SIZECB 102 APOS = POSELT + int(NPIV+NBROW,8) 103 & * int(LDA,8) - 1_8 104 IF ( KEEP(50) .EQ. 0 .OR. .NOT. COMPRESSCB ) THEN 105 APOS = APOS - int(LDA,8) * int(NBROW_ALREADY_STACKED,8) 106 NPOS = NPOS 107 & - int(NBCOL_STACK,8) * int(NBROW_ALREADY_STACKED,8) 108 ELSE 109 APOS = APOS - int(LDA - 1,8) * int(NBROW_ALREADY_STACKED,8) 110 NPOS = NPOS - ( int(NBROW_ALREADY_STACKED,8) * 111 & int(NBROW_ALREADY_STACKED+1,8) ) / 2_8 112 ENDIF 113 DO I = NBROW - NBROW_ALREADY_STACKED, NBROW_SEND+1, -1 114 IF (KEEP(50).EQ.0) THEN 115 IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. 116 & LAST_ALLOWED ) THEN 117 EXIT 118 ENDIF 119 DO J= 1_8,int(NBCOL_STACK,8) 120 A(NPOS-J+1_8) = A(APOS-J+1_8) 121 ENDDO 122 NPOS = NPOS - int(NBCOL_STACK,8) 123 ELSE 124 IF (.NOT. COMPRESSCB) THEN 125 IF ( NPOS - int(NBCOL_STACK,8) + 1_8 .LT. 126 & LAST_ALLOWED ) THEN 127 EXIT 128 ENDIF 129#if defined(ZERO_TRIANGLE) 130 DO J = 1_8, int(NBCOL_STACK - I,8) 131 A(NPOS - J + 1_8) = ZERO 132 END DO 133#endif 134 NPOS = NPOS + int(- NBCOL_STACK + I,8) 135 ENDIF 136 IF ( NPOS - int(I,8) + 1_8 .LT. LAST_ALLOWED ) THEN 137 EXIT 138 ENDIF 139 DO J =1_8, int(I,8) 140 A(NPOS-J+1_8) = A(APOS-J+1_8) 141 ENDDO 142 NPOS = NPOS - int(I,8) 143 ENDIF 144 IF (KEEP(50).EQ.0) THEN 145 APOS = APOS - int(LDA,8) 146 ELSE 147 APOS = APOS - int(LDA + 1,8) 148 ENDIF 149 NBROW_ALREADY_STACKED = NBROW_ALREADY_STACKED + 1 150 ENDDO 151 END IF 152 RETURN 153 END SUBROUTINE ZMUMPS_COPY_CB_RIGHT_TO_LEFT 154 SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT( A, LA, LDA, POSELT, 155 & IPTRLU, NPIV, 156 & NBCOL_STACK, NBROW_STACK, 157 & NBROW_SEND, SIZECB, KEEP, COMPRESSCB) 158 IMPLICIT NONE 159 INTEGER(8), intent (in) :: POSELT, IPTRLU, LA, SIZECB 160 LOGICAL, intent (in) :: COMPRESSCB 161 COMPLEX(kind=8) A(LA) 162 INTEGER, intent(in):: LDA, NPIV, NBCOL_STACK, NBROW_STACK, 163 & NBROW_SEND 164 INTEGER(8) :: APOS, NPOS, APOS_ini, NPOS_ini 165 INTEGER I, KEEP(500) 166 INTEGER(8) :: J, LDA8 167#if defined(ZERO_TRIANGLE) 168 COMPLEX(kind=8) ZERO 169 PARAMETER( ZERO = (0.0D0,0.0D0) ) 170#endif 171 LDA8 = int(LDA,8) 172 NPOS_ini = IPTRLU + 1_8 173 APOS_ini = POSELT + int(NPIV+NBROW_SEND,8)* LDA8 + int(NPIV,8) 174!$OMP PARALLEL DO PRIVATE(J, NPOS, APOS) IF (NBROW_STACK > 300) 175 DO I = 1, NBROW_STACK 176 IF (COMPRESSCB) THEN 177 NPOS = NPOS_ini + int(I-1,8) * int(I,8)/2_8 + 178 & int(I-1,8) * int(NBROW_SEND,8) 179 ELSE 180 NPOS = NPOS_ini + int(I-1,8) * int(NBCOL_STACK,8) 181 ENDIF 182 APOS = APOS_ini + int(I-1,8) * LDA8 183 IF (KEEP(50).EQ.0) THEN 184 DO J = 1_8, int(NBCOL_STACK,8) 185 A(NPOS+J-1_8) = A(APOS+J-1_8) 186 ENDDO 187 ELSE 188 DO J = 1_8, int(I + NBROW_SEND,8) 189 A(NPOS+J-1_8)=A(APOS+J-1_8) 190 ENDDO 191#if defined(ZERO_TRIANGLE) 192 IF (.NOT. COMPRESSCB) THEN 193 A(NPOS+int(I+NBROW_SEND,8): 194 & NPOS+int(NBCOL_STACK-1,8))=ZERO 195 ENDIF 196#endif 197 ENDIF 198 ENDDO 199!$OMP END PARALLEL DO 200 RETURN 201 END SUBROUTINE ZMUMPS_COPY_CB_LEFT_TO_RIGHT 202