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 DMUMPS_ELT_ASM_S_2_S_INIT(
14     &    NELT, FRT_PTR, FRT_ELT,
15     &    N, INODE, IW, LIW, A, LA,
16     &    NBROWS, NBCOLS,
17     &    OPASSW, OPELIW, STEP, PTRIST, PTRAST, ITLOC,
18     &    RHS_MUMPS,
19     &    FILS, PTRARW, PTRAIW, INTARR, DBLARR,
20     &    ICNTL, KEEP, KEEP8, MYID)
21      IMPLICIT NONE
22      INTEGER NELT, N,LIW
23      INTEGER(8) :: LA
24      INTEGER KEEP(500), ICNTL(40)
25      INTEGER(8) KEEP8(150)
26      INTEGER INODE, MYID
27      INTEGER NBROWS, NBCOLS
28      INTEGER(8) :: PTRAST(KEEP(28))
29      INTEGER IW(LIW), ITLOC(N + KEEP(253)), STEP(N),
30     &        PTRIST(KEEP(28)),
31     &        FILS(N)
32      INTEGER(8), INTENT(IN) :: PTRARW(NELT+1), PTRAIW(NELT+1)
33      DOUBLE PRECISION :: RHS_MUMPS(KEEP(255))
34      INTEGER INTARR(KEEP8(27))
35      INTEGER FRT_PTR(N+1), FRT_ELT(NELT)
36      DOUBLE PRECISION :: A(LA)
37      DOUBLE PRECISION :: DBLARR(KEEP8(26))
38      DOUBLE PRECISION OPASSW, OPELIW
39      INTEGER(8) :: POSELT
40      INTEGER IOLDPS, NBCOLF, NBROWF, NSLAVES, HF,
41     &        K1,K2,K,J,JPOS,NASS
42      DOUBLE PRECISION ZERO
43      PARAMETER( ZERO = 0.0D0 )
44      INCLUDE 'mumps_headers.h'
45      IOLDPS  = PTRIST(STEP(INODE))
46      POSELT  = PTRAST(STEP(INODE))
47      NBCOLF  = IW(IOLDPS+KEEP(IXSZ))
48      NBROWF  = IW(IOLDPS+2+KEEP(IXSZ))
49      NASS    = IW(IOLDPS+1+KEEP(IXSZ))
50      NSLAVES = IW(IOLDPS+5+KEEP(IXSZ))
51      HF      = 6 + NSLAVES+KEEP(IXSZ)
52      IF (NASS.LT.0) THEN
53          NASS         = -NASS
54          IW(IOLDPS+1+KEEP(IXSZ)) = NASS
55          CALL DMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW,
56     &    IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS,
57     &    PTRAIW, PTRARW,
58     &    INTARR, DBLARR, KEEP8(27), KEEP8(26), FRT_PTR, FRT_ELT,
59     &    RHS_MUMPS)
60      END IF
61      IF (NBROWS.GT.0) THEN
62          K1 = IOLDPS + HF + NBROWF
63          K2 = K1 + NBCOLF - 1
64          JPOS = 1
65          DO K = K1, K2
66           J        = IW(K)
67           ITLOC(J) = JPOS
68           JPOS     = JPOS + 1
69          END DO
70      END IF
71      RETURN
72      END SUBROUTINE DMUMPS_ELT_ASM_S_2_S_INIT
73      SUBROUTINE DMUMPS_ASM_SLAVE_ELEMENTS( INODE, N, NELT, IW, LIW,
74     &IOLDPS, A, LA, POSELT, KEEP, KEEP8, ITLOC, FILS, PTRAIW, PTRARW,
75     &INTARR, DBLARR, LINTARR, LDBLARR, FRT_PTR, FRT_ELT, RHS_MUMPS)
76      IMPLICIT NONE
77      INTEGER, intent(in)    :: N, NELT, LIW, IOLDPS, INODE
78      INTEGER(8), intent(in) :: LA, POSELT, LINTARR, LDBLARR
79      INTEGER, intent(in)    :: IW(LIW)
80      INTEGER, intent(in)    :: KEEP(500)
81      INTEGER(8), intent(in) :: KEEP8(150)
82      INTEGER, intent(inout) :: ITLOC(N+KEEP(253))
83      DOUBLE PRECISION, intent(inout) :: A(LA)
84      DOUBLE PRECISION, intent(in)    :: RHS_MUMPS(KEEP(255))
85      INTEGER, intent(in)    :: INTARR(LINTARR)
86      DOUBLE PRECISION, intent(in)    :: DBLARR(LDBLARR)
87      INTEGER, intent(in)    :: FRT_PTR(N+1), FRT_ELT(NELT)
88      INTEGER, intent(in)    :: FILS(N)
89      INTEGER(8), intent(in) :: PTRAIW(NELT+1), PTRARW(NELT+1)
90      INCLUDE 'mumps_headers.h'
91      INTEGER    :: HF, NBROWF, NBCOLF, NASS, NSLAVES
92      INTEGER    :: ILOC, IELL, ELTI, ELBEG, NUMELT
93      INTEGER(8) :: SIZE_ELTI8
94      INTEGER    :: I, J, K, K1, K2
95      INTEGER    :: IPOS, IPOS1, IPOS2, JPOS, IJROW
96      INTEGER    :: IN
97      INTEGER(8) :: II8, JJ8, J18, J28
98      INTEGER(8) :: AINPUT8
99      INTEGER(8) :: AII8
100      INTEGER(8) :: APOS, APOS2, ICT12
101      INTEGER    :: K1RHS, K2RHS, JFirstRHS
102      DOUBLE PRECISION ZERO
103      PARAMETER( ZERO = 0.0D0 )
104      NBCOLF  = IW(IOLDPS+KEEP(IXSZ))
105      NBROWF  = IW(IOLDPS+2+KEEP(IXSZ))
106      NASS    = IW(IOLDPS+1+KEEP(IXSZ))
107      A(POSELT:POSELT+int(NBROWF,8)*int(NBCOLF,8)-1_8) = ZERO
108      NSLAVES= IW(IOLDPS+5 + KEEP(IXSZ))
109      HF      = 6 + NSLAVES + KEEP(IXSZ)
110          K1 = IOLDPS + HF + NBROWF
111          K2 = K1 + NBCOLF - 1
112          JPOS = 1
113          DO K = K1, K2
114           J        = IW(K)
115           ITLOC(J) = -JPOS
116           JPOS     = JPOS + 1
117          END DO
118          K1 = IOLDPS + HF
119          K2 = K1 + NBROWF - 1
120          JPOS = 1
121          IF ((KEEP(253).GT.0).AND.(KEEP(50).NE.0)) THEN
122           K1RHS = 0
123           K2RHS = -1
124           DO K = K1, K2
125            J        = IW(K)
126            ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS
127            IF ((K1RHS.EQ.0).AND.(J.GT.N)) THEN
128             K1RHS = K
129             JFirstRHS=J-N
130            ENDIF
131            JPOS     = JPOS + 1
132           ENDDO
133           IF (K1RHS.GT.0) K2RHS=K2
134           IF ( K2RHS.GE.K1RHS ) THEN
135             IN = INODE
136             DO WHILE (IN.GT.0)
137               IJROW = -ITLOC(IN)
138               DO K = K1RHS, K2RHS
139                J    = IW(K)
140                I    = ITLOC(J)
141                ILOC = mod(I,NBCOLF)
142              APOS = POSELT+int(ILOC-1,8)*int(NBCOLF,8) +
143     &               int(IJROW-1,8)
144              A(APOS) = A(APOS) + RHS_MUMPS(
145     &                 (JFirstRHS+(K-K1RHS)-1)*KEEP(254)+ IN)
146             ENDDO
147             IN = FILS(IN)
148            ENDDO
149           ENDIF
150          ELSE
151           DO K = K1, K2
152            J        = IW(K)
153            ITLOC(J) = -ITLOC(J)*NBCOLF + JPOS
154            JPOS     = JPOS + 1
155           END DO
156          ENDIF
157          ELBEG  = FRT_PTR(INODE)
158          NUMELT = FRT_PTR(INODE+1) - ELBEG
159          DO IELL=ELBEG,ELBEG+NUMELT-1
160           ELTI = FRT_ELT(IELL)
161           J18= PTRAIW(ELTI)
162           J28= PTRAIW(ELTI+1)-1_8
163           AII8 = PTRARW(ELTI)
164           SIZE_ELTI8 = J28 - J18 + 1_8
165           DO II8=J18,J28
166            I = ITLOC(INTARR(II8))
167            IF (KEEP(50).EQ.0) THEN
168             IF (I.LE.0) CYCLE
169             AINPUT8    = AII8 + II8 - J18
170             IPOS = mod(I,NBCOLF)
171             ICT12 = POSELT + int(IPOS-1,8) * int(NBCOLF,8)
172             DO JJ8 = J18, J28
173              JPOS = ITLOC(INTARR(JJ8))
174              IF (JPOS.LE.0) THEN
175                   JPOS = -JPOS
176              ELSE
177                   JPOS = JPOS/NBCOLF
178              END IF
179              APOS2    = ICT12 + int(JPOS - 1,8)
180              A(APOS2) = A(APOS2) +  DBLARR(AINPUT8)
181              AINPUT8   = AINPUT8 + SIZE_ELTI8
182             END DO
183            ELSE
184              IF ( I .EQ. 0 ) THEN
185               AII8 = AII8 + J28 - II8 + 1_8
186               CYCLE
187              ENDIF
188              IF ( I .LE. 0 ) THEN
189               IPOS1 = -I
190               IPOS2 = 0
191              ELSE
192               IPOS1 = I/NBCOLF
193               IPOS2 = mod(I,NBCOLF)
194              END IF
195              ICT12 =  POSELT + int(IPOS2-1,8)*int(NBCOLF,8)
196              DO JJ8=II8,J28
197               AII8 = AII8 + 1_8
198               J = ITLOC(INTARR(JJ8))
199               IF ( J .EQ. 0 ) CYCLE
200               IF ( IPOS2.EQ.0 .AND. J.LE.0) CYCLE
201               IF ( J .LE. 0 ) THEN
202                JPOS = -J
203               ELSE
204                JPOS = J/NBCOLF
205               END IF
206               IF ( (IPOS1.GE.JPOS) .AND. (IPOS2.GT.0) ) THEN
207                 APOS2 = ICT12  + int(JPOS - 1,8)
208                 A(APOS2) = A(APOS2) +  DBLARR(AII8-1_8)
209               END IF
210               IF ( (IPOS1.LT.JPOS) .AND. (J.GT.0) ) THEN
211                 IPOS = mod(J,NBCOLF)
212                 JPOS = IPOS1
213                 APOS2 = POSELT + int(IPOS-1,8)*int(NBCOLF,8)
214     &                          + int(JPOS - 1,8)
215                 A(APOS2) = A(APOS2) +  DBLARR(AII8-1_8)
216               END IF
217              END DO
218            END IF
219           END DO
220          END DO
221          K1 = IOLDPS + HF + NBROWF
222          K2 = K1 + NBCOLF - 1
223          DO K = K1, K2
224           J = IW(K)
225           ITLOC(J) = 0
226          END DO
227      END SUBROUTINE DMUMPS_ASM_SLAVE_ELEMENTS
228