File: cmumps_f77.F

package info (click to toggle)
mumps 5.1.2-5
  • links: PTS, VCS
  • area: main
  • in suites: sid
  • size: 15,704 kB
  • sloc: fortran: 310,672; ansic: 12,364; xml: 521; makefile: 469
file content (354 lines) | stat: -rw-r--r-- 13,758 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
C
C  This file is part of MUMPS 5.1.2, released
C  on Mon Oct  2 07:37:01 UTC 2017
C
C
C  Copyright 1991-2017 CERFACS, CNRS, ENS Lyon, INP Toulouse, Inria,
C  University of Bordeaux.
C
C  This version of MUMPS is provided to you free of charge. It is
C  released under the CeCILL-C license:
C  http://www.cecill.info/licences/Licence_CeCILL-C_V1-en.html
C
      SUBROUTINE CMUMPS_F77( JOB, SYM, PAR, COMM_F77, N, ICNTL, CNTL,
     &                      KEEP, DKEEP, KEEP8,
     &                      NZ, NNZ, IRN, IRNhere, JCN, JCNhere,
     &                      A, Ahere,
     &                      NZ_loc, NNZ_loc, IRN_loc, IRN_lochere,
     &                      JCN_loc, JCN_lochere,
     &                      A_loc, A_lochere,
     &                      NELT, ELTPTR, ELTPTRhere,  ELTVAR,
     &                      ELTVARhere, A_ELT, A_ELThere,
     &                      PERM_IN, PERM_INhere,
     &                      RHS, RHShere, REDRHS, REDRHShere,
     &                      INFO, RINFO, INFOG, RINFOG,
     &                      DEFICIENCY, LWK_USER,
     &                      SIZE_SCHUR, LISTVAR_SCHUR,
     &                      LISTVAR_SCHURhere, SCHUR, SCHURhere,
     &                      WK_USER, WK_USERhere,
     &                      COLSCA, COLSCAhere, ROWSCA, ROWSCAhere,
     &                      INSTANCE_NUMBER, NRHS, LRHS, LREDRHS,
     &
     &                      RHS_SPARSE, RHS_SPARSEhere,
     &                      SOL_loc, SOL_lochere,
     &                      IRHS_SPARSE, IRHS_SPARSEhere,
     &                      IRHS_PTR, IRHS_PTRhere,
     &                      ISOL_loc, ISOL_lochere,
     &                      NZ_RHS, LSOL_loc
     &                      , 
     & SCHUR_MLOC,
     & SCHUR_NLOC,
     & SCHUR_LLD,
     & MBLOCK,
     & NBLOCK,
     & NPROW,
     & NPCOL,
     &
     & OOC_TMPDIR,
     & OOC_PREFIX,
     & WRITE_PROBLEM,
     & TMPDIRLEN,
     & PREFIXLEN,
     & WRITE_PROBLEMLEN
     &
     & )
      USE CMUMPS_STRUC_DEF
      IMPLICIT NONE
      INTEGER OOC_PREFIX_MAX_LENGTH, OOC_TMPDIR_MAX_LENGTH
      INTEGER PB_MAX_LENGTH
      PARAMETER(OOC_PREFIX_MAX_LENGTH=63, OOC_TMPDIR_MAX_LENGTH=255)
      PARAMETER(PB_MAX_LENGTH=255)
      INTEGER JOB, SYM, PAR, COMM_F77, N, NZ, NZ_loc, NELT,
     &        DEFICIENCY, LWK_USER, SIZE_SCHUR, INSTANCE_NUMBER,
     &        NRHS, LRHS,
     &        NZ_RHS, LSOL_loc, LREDRHS
      INTEGER(8) :: NNZ, NNZ_loc
      INTEGER ICNTL(40), INFO(40), INFOG(40), KEEP(500)
      INTEGER SCHUR_MLOC, SCHUR_NLOC, SCHUR_LLD
      INTEGER MBLOCK, NBLOCK, NPROW, NPCOL
      INTEGER TMPDIRLEN, PREFIXLEN, WRITE_PROBLEMLEN
      REAL CNTL(15), RINFO(40), RINFOG(40), DKEEP(230)
      INTEGER(8) KEEP8(150)
      INTEGER, TARGET :: IRN(*), JCN(*), ELTPTR(*), ELTVAR(*)
      INTEGER, TARGET :: PERM_IN(*), IRN_loc(*), JCN_loc(*)
      INTEGER, TARGET :: LISTVAR_SCHUR(*)
      INTEGER, TARGET :: IRHS_PTR(*), IRHS_SPARSE(*), ISOL_loc(*)
      COMPLEX, TARGET :: A(*), A_ELT(*), A_loc(*), RHS(*)
      COMPLEX, TARGET :: WK_USER(*)
      COMPLEX, TARGET :: REDRHS(*)
      REAL, TARGET :: ROWSCA(*), COLSCA(*)
      COMPLEX, TARGET :: SCHUR(*)
      COMPLEX, TARGET :: RHS_SPARSE(*), SOL_loc(*)
      INTEGER, INTENT(inout) :: OOC_TMPDIR(OOC_TMPDIR_MAX_LENGTH)
      INTEGER, INTENT(inout) :: OOC_PREFIX(OOC_PREFIX_MAX_LENGTH)
      INTEGER, INTENT(in) :: WRITE_PROBLEM(PB_MAX_LENGTH)
      INTEGER IRNhere, JCNhere, Ahere, ELTPTRhere, ELTVARhere,
     &        A_ELThere, PERM_INhere, WK_USERhere,
     &        RHShere, REDRHShere, IRN_lochere,
     &        JCN_lochere, A_lochere, LISTVAR_SCHURhere,
     &        SCHURhere, COLSCAhere, ROWSCAhere, RHS_SPARSEhere,
     &        SOL_lochere, IRHS_PTRhere, IRHS_SPARSEhere, ISOL_lochere
      INCLUDE 'mpif.h'
      TYPE CMUMPS_STRUC_PTR
          TYPE (CMUMPS_STRUC), POINTER :: PTR
      END TYPE CMUMPS_STRUC_PTR
      TYPE (CMUMPS_STRUC), POINTER :: mumps_par
      TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER, SAVE ::
     &  mumps_par_array
      TYPE (CMUMPS_STRUC_PTR), DIMENSION (:), POINTER ::
     &  mumps_par_array_bis
      INTEGER, SAVE :: CMUMPS_STRUC_ARRAY_SIZE = 0
      INTEGER, SAVE :: N_INSTANCES = 0
      INTEGER A_ELT_SIZE, I, Np, IERR
      INTEGER(8) :: NNZ_i
      INTEGER CMUMPS_STRUC_ARRAY_SIZE_INIT
      PARAMETER (CMUMPS_STRUC_ARRAY_SIZE_INIT=10)
      EXTERNAL MUMPS_ASSIGN_MAPPING,
     &         MUMPS_ASSIGN_PIVNUL_LIST,
     &         MUMPS_ASSIGN_SYM_PERM,
     &         MUMPS_ASSIGN_UNS_PERM
      EXTERNAL CMUMPS_ASSIGN_COLSCA,
     &         CMUMPS_ASSIGN_ROWSCA
      IF (JOB == -1) THEN
        DO I = 1, CMUMPS_STRUC_ARRAY_SIZE
          IF ( .NOT. associated(mumps_par_array(I)%PTR) ) GOTO 10
        END DO
        ALLOCATE( mumps_par_array_bis(CMUMPS_STRUC_ARRAY_SIZE +
     &  CMUMPS_STRUC_ARRAY_SIZE_INIT), stat=IERR)
        IF (IERR /= 0) THEN
          WRITE(*,*) ' ** Allocation Error 1 in CMUMPS_F77.'
          CALL MUMPS_ABORT()
        END IF
        DO I = 1, CMUMPS_STRUC_ARRAY_SIZE
          mumps_par_array_bis(I)%PTR=>mumps_par_array(I)%PTR
        ENDDO
        IF (associated(mumps_par_array)) DEALLOCATE(mumps_par_array)
        mumps_par_array=>mumps_par_array_bis
        NULLIFY(mumps_par_array_bis)
        DO I = CMUMPS_STRUC_ARRAY_SIZE+1, CMUMPS_STRUC_ARRAY_SIZE +
     &  CMUMPS_STRUC_ARRAY_SIZE_INIT
          NULLIFY(mumps_par_array(I)%PTR)
        ENDDO
        I = CMUMPS_STRUC_ARRAY_SIZE+1
        CMUMPS_STRUC_ARRAY_SIZE = CMUMPS_STRUC_ARRAY_SIZE +
     &  CMUMPS_STRUC_ARRAY_SIZE_INIT
 10     CONTINUE
        INSTANCE_NUMBER = I
        N_INSTANCES = N_INSTANCES+1
        ALLOCATE( mumps_par_array(INSTANCE_NUMBER)%PTR,stat=IERR )
        IF (IERR /= 0) THEN
          WRITE(*,*) '** Allocation Error 2 in CMUMPS_F77.'
          CALL MUMPS_ABORT()
        ENDIF
        mumps_par_array(INSTANCE_NUMBER)%PTR%KEEP(40) = 0
        mumps_par_array(INSTANCE_NUMBER)%PTR%INSTANCE_NUMBER =
     &  INSTANCE_NUMBER
      END IF
      IF ( INSTANCE_NUMBER .LE. 0 .OR. INSTANCE_NUMBER .GT.
     &     CMUMPS_STRUC_ARRAY_SIZE ) THEN
        WRITE(*,*) ' ** Instance Error 1 in CMUMPS_F77',
     &             INSTANCE_NUMBER
        CALL MUMPS_ABORT()
      END IF
      IF ( .NOT. associated ( mumps_par_array(INSTANCE_NUMBER)%PTR ) )
     &  THEN
        WRITE(*,*) ' Instance Error 2 in CMUMPS_F77',
     &             INSTANCE_NUMBER
        CALL MUMPS_ABORT()
      END IF
      mumps_par => mumps_par_array(INSTANCE_NUMBER)%PTR
      mumps_par%SYM = SYM
      mumps_par%PAR = PAR
      mumps_par%JOB = JOB
      mumps_par%N   = N
      mumps_par%NZ  = NZ
      mumps_par%NNZ  = NNZ
      mumps_par%NZ_loc  = NZ_loc
      mumps_par%NNZ_loc  = NNZ_loc
      mumps_par%LWK_USER = LWK_USER
      mumps_par%SIZE_SCHUR  = SIZE_SCHUR
      mumps_par%NELT= NELT
      mumps_par%ICNTL(1:40)=ICNTL(1:40)
      mumps_par%CNTL(1:15)=CNTL(1:15)
      mumps_par%KEEP(1:500)=KEEP(1:500)
      mumps_par%DKEEP(1:230)=DKEEP(1:230)
      mumps_par%KEEP8(1:150)=KEEP8(1:150)
      mumps_par%NRHS  = NRHS
      mumps_par%LRHS  = LRHS
      mumps_par%LREDRHS = LREDRHS
      mumps_par%NZ_RHS   = NZ_RHS
      mumps_par%LSOL_loc = LSOL_loc
      mumps_par%SCHUR_MLOC   = SCHUR_MLOC
      mumps_par%SCHUR_NLOC   = SCHUR_NLOC
      mumps_par%SCHUR_LLD    = SCHUR_LLD
      mumps_par%MBLOCK = MBLOCK
      mumps_par%NBLOCK = NBLOCK
      mumps_par%NPROW  = NPROW
      mumps_par%NPCOL  = NPCOL
      IF ( COMM_F77 .NE. -987654 ) THEN
        mumps_par%COMM = COMM_F77
      ELSE
        mumps_par%COMM = MPI_COMM_WORLD
      ENDIF
      CALL MPI_BCAST(NRHS,1,MPI_INTEGER,0,mumps_par%COMM,IERR)
      CALL MUMPS_GET_NNZ_INTERNAL(NNZ,NZ,NNZ_i)
      IF ( IRNhere /= 0 ) mumps_par%IRN => IRN(1:NNZ_i)
      IF ( JCNhere /= 0 ) mumps_par%JCN => JCN(1:NNZ_i)
      IF ( Ahere /= 0 )   mumps_par%A   => A(1:NNZ_i)
      CALL MUMPS_GET_NNZ_INTERNAL(NNZ_loc,NZ_loc,NNZ_i)
      IF ( IRN_lochere /= 0 ) mumps_par%IRN_loc => IRN_loc(1:NNZ_i)
      IF ( JCN_lochere /= 0 ) mumps_par%JCN_loc => JCN_loc(1:NNZ_i)
      IF ( A_lochere /= 0 )   mumps_par%A_loc   => A_loc(1:NNZ_i)
      IF ( ELTPTRhere /= 0 ) mumps_par%ELTPTR => ELTPTR(1:NELT+1)
      IF ( ELTVARhere /= 0 ) mumps_par%ELTVAR =>
     &   ELTVAR(1:ELTPTR(NELT+1)-1)
      IF ( A_ELThere /= 0 ) THEN
        A_ELT_SIZE = 0
        DO I = 1, NELT
          Np = ELTPTR(I+1) -ELTPTR(I)
          IF (SYM == 0) THEN
            A_ELT_SIZE = A_ELT_SIZE + Np * Np
          ELSE
            A_ELT_SIZE = A_ELT_SIZE + Np * ( Np + 1 ) / 2
          END IF
        END DO
        mumps_par%A_ELT => A_ELT(1:A_ELT_SIZE)
      END IF
      IF ( PERM_INhere /= 0) mumps_par%PERM_IN => PERM_IN(1:N)
      IF ( LISTVAR_SCHURhere /= 0)
     &   mumps_par%LISTVAR_SCHUR =>LISTVAR_SCHUR(1:SIZE_SCHUR)
      IF ( SCHURhere /= 0 ) THEN
        mumps_par%SCHUR_CINTERFACE=>SCHUR(1:1)
      ENDIF
      IF (NRHS .NE. 1) THEN
        IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:NRHS*LRHS)
        IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:NRHS*LREDRHS)
      ELSE
        IF ( RHShere /= 0 ) mumps_par%RHS => RHS(1:N)
        IF (REDRHShere /= 0)mumps_par%REDRHS=>REDRHS(1:SIZE_SCHUR)
      ENDIF
      IF ( WK_USERhere /=0 ) THEN
        IF (LWK_USER > 0 ) THEN
          mumps_par%WK_USER => WK_USER(1:LWK_USER)
        ELSE
          mumps_par%WK_USER => WK_USER(1_8:-int(LWK_USER,8)*1000000_8)
        ENDIF
      ENDIF
      IF ( COLSCAhere /= 0) mumps_par%COLSCA => COLSCA(1:N)
      IF ( ROWSCAhere /= 0) mumps_par%ROWSCA => ROWSCA(1:N)
      IF ( RHS_SPARSEhere /=0 ) mumps_par%RHS_SPARSE=>
     &                          RHS_SPARSE(1:NZ_RHS)
      IF ( IRHS_SPARSEhere /=0 ) mumps_par%IRHS_SPARSE=>
     &                          IRHS_SPARSE(1:NZ_RHS)
      IF ( SOL_lochere /=0 ) mumps_par%SOL_loc=>
     &                          SOL_loc(1:LSOL_loc*NRHS)
      IF ( ISOL_lochere /=0 ) mumps_par%ISOL_loc=>
     &                          ISOL_loc(1:LSOL_loc)
      IF ( IRHS_PTRhere /=0 ) mumps_par%IRHS_PTR=>
     &                          IRHS_PTR(1:NRHS+1)
      DO I=1,TMPDIRLEN
        mumps_par%OOC_TMPDIR(I:I)=char(OOC_TMPDIR(I))
      ENDDO
      DO I=TMPDIRLEN+1,OOC_TMPDIR_MAX_LENGTH
        mumps_par%OOC_TMPDIR(I:I)=' '
      ENDDO
      DO I=1,PREFIXLEN
        mumps_par%OOC_PREFIX(I:I)=char(OOC_PREFIX(I))
      ENDDO
      DO I=PREFIXLEN+1,OOC_PREFIX_MAX_LENGTH
        mumps_par%OOC_PREFIX(I:I)=' '
      ENDDO
      DO I=1,WRITE_PROBLEMLEN
        mumps_par%WRITE_PROBLEM(I:I)=char(WRITE_PROBLEM(I))
      ENDDO
      DO I=WRITE_PROBLEMLEN+1,PB_MAX_LENGTH
        mumps_par%WRITE_PROBLEM(I:I)=' '
      ENDDO
      CALL CMUMPS( mumps_par )
      INFO(1:40)=mumps_par%INFO(1:40)
      INFOG(1:40)=mumps_par%INFOG(1:40)
      RINFO(1:40)=mumps_par%RINFO(1:40)
      RINFOG(1:40)=mumps_par%RINFOG(1:40)
      ICNTL(1:40) = mumps_par%ICNTL(1:40)
      CNTL(1:15) = mumps_par%CNTL(1:15)
      KEEP(1:500) = mumps_par%KEEP(1:500)
      DKEEP(1:230) = mumps_par%DKEEP(1:230)
      KEEP8(1:150) = mumps_par%KEEP8(1:150)
      SYM = mumps_par%SYM
      PAR = mumps_par%PAR
      JOB = mumps_par%JOB
      N   = mumps_par%N
      NZ  = mumps_par%NZ
      NNZ = mumps_par%NNZ
      NRHS = mumps_par%NRHS
      LRHS = mumps_par%LRHS
      LREDRHS = mumps_par%LREDRHS
      NZ_loc  = mumps_par%NZ_loc
      NNZ_loc  = mumps_par%NNZ_loc
      NZ_RHS  = mumps_par%NZ_RHS
      LSOL_loc= mumps_par%LSOL_loc
      SIZE_SCHUR  = mumps_par%SIZE_SCHUR
      LWK_USER = mumps_par%LWK_USER
      NELT= mumps_par%NELT
      DEFICIENCY = mumps_par%Deficiency
      SCHUR_MLOC   = mumps_par%SCHUR_MLOC
      SCHUR_NLOC   = mumps_par%SCHUR_NLOC
      SCHUR_LLD    = mumps_par%SCHUR_LLD
      MBLOCK       = mumps_par%MBLOCK
      NBLOCK       = mumps_par%NBLOCK
      NPROW        = mumps_par%NPROW
      NPCOL        = mumps_par%NPCOL
      IF ( associated (mumps_par%MAPPING) ) THEN
         CALL MUMPS_ASSIGN_MAPPING(mumps_par%MAPPING(1))
      ELSE
         CALL MUMPS_NULLIFY_C_MAPPING()
      ENDIF
      IF ( associated (mumps_par%PIVNUL_LIST) ) THEN
         CALL MUMPS_ASSIGN_PIVNUL_LIST(mumps_par%PIVNUL_LIST(1))
      ELSE
         CALL MUMPS_NULLIFY_C_PIVNUL_LIST()
      ENDIF
      IF ( associated (mumps_par%SYM_PERM) ) THEN
         CALL MUMPS_ASSIGN_SYM_PERM(mumps_par%SYM_PERM(1))
      ELSE
         CALL MUMPS_NULLIFY_C_SYM_PERM()
      ENDIF
      IF ( associated (mumps_par%UNS_PERM) ) THEN
         CALL MUMPS_ASSIGN_UNS_PERM(mumps_par%UNS_PERM(1))
      ELSE
         CALL MUMPS_NULLIFY_C_UNS_PERM()
      ENDIF
      IF (associated( mumps_par%COLSCA)) THEN
          CALL CMUMPS_ASSIGN_COLSCA(mumps_par%COLSCA(1))
      ELSE
          CALL CMUMPS_NULLIFY_C_COLSCA()
      ENDIF
      IF (associated( mumps_par%ROWSCA)) THEN
          CALL CMUMPS_ASSIGN_ROWSCA(mumps_par%ROWSCA(1))
      ELSE
          CALL CMUMPS_NULLIFY_C_ROWSCA()
      ENDIF
      TMPDIRLEN=len_trim(mumps_par%OOC_TMPDIR)
      DO I=1,OOC_TMPDIR_MAX_LENGTH
         OOC_TMPDIR(I)=ichar(mumps_par%OOC_TMPDIR(I:I))
      ENDDO
      PREFIXLEN=len_trim(mumps_par%OOC_PREFIX)
      DO I=1,OOC_PREFIX_MAX_LENGTH
         OOC_PREFIX(I)=ichar(mumps_par%OOC_PREFIX(I:I))
      ENDDO
      IF ( JOB == -2 ) THEN
         IF (associated(mumps_par_array(INSTANCE_NUMBER)%PTR))THEN
           DEALLOCATE(mumps_par_array(INSTANCE_NUMBER)%PTR)
           NULLIFY   (mumps_par_array(INSTANCE_NUMBER)%PTR)
           N_INSTANCES = N_INSTANCES - 1
           IF ( N_INSTANCES == 0 ) THEN
             DEALLOCATE(mumps_par_array)
             CMUMPS_STRUC_ARRAY_SIZE = 0
           END IF
         ELSE
           WRITE(*,*) "** Warning: instance already freed"
           WRITE(*,*) "            this should normally not happen."
         ENDIF
      END IF
      RETURN
      END SUBROUTINE CMUMPS_F77