File: zfac_process_contrib_type1.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 (117 lines) | stat: -rw-r--r-- 4,452 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
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 ZMUMPS_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP,
     &           BUFR, LBUFR, LBUFR_BYTES,
     &           IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS,
     &           N, IW, LIW, A, LA,
     &           PTRIST, PTRAST, STEP, PIMASTER, PAMASTER,
     &           NSTK_S, COMP,
     &           FPERE, FLAG, IFLAG, IERROR, COMM,
     &           ITLOC, RHS_MUMPS )
      IMPLICIT NONE
      INCLUDE 'mpif.h'
      INTEGER IERR
      INTEGER MYID
      INTEGER LBUFR, LBUFR_BYTES
      INTEGER KEEP(500), BUFR( LBUFR )
      INTEGER(8) KEEP8(150)
      DOUBLE PRECISION DKEEP(230)
      INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS
      INTEGER IWPOS, IWPOSCB
      INTEGER N, LIW
      INTEGER IW( LIW )
      COMPLEX(kind=8) A( LA )
      INTEGER(8) :: PTRAST  (KEEP(28))
      INTEGER(8) :: PAMASTER(KEEP(28))
      INTEGER PTRIST( KEEP(28) )
      INTEGER STEP(N), PIMASTER(KEEP(28))
      INTEGER COMP, FPERE
      LOGICAL FLAG
      INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) )
      COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255))
      INTEGER IFLAG, IERROR, COMM
      INTEGER POSITION, FINODE, FLCONT, LREQ
      INTEGER(8) :: LREQCB
      INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET
      INTEGER SIZE_PACKET
      INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET
      INCLUDE 'mumps_headers.h'
      LOGICAL COMPRESSCB
      FLAG = .FALSE.
      POSITION = 0
      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &                FINODE, 1, MPI_INTEGER,
     &                COMM, IERR)
      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &                FPERE, 1, MPI_INTEGER, 
     &                COMM, IERR)
      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &                FLCONT, 1, MPI_INTEGER,
     &                COMM, IERR)
      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &                NBROWS_ALREADY_SENT, 1, MPI_INTEGER,
     &                COMM, IERR)
      CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &                NBROWS_PACKET, 1, MPI_INTEGER,
     &                COMM, IERR)
      COMPRESSCB = (FLCONT.LT.0) 
      IF (COMPRESSCB) THEN
        FLCONT   = -FLCONT
        LREQCB  = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8
      ELSE
        LREQCB  = int(FLCONT,8) * int(FLCONT,8)
      ENDIF
      IF (NBROWS_ALREADY_SENT == 0) THEN
        LREQ    = 2 * FLCONT + 6 + KEEP(IXSZ)
        IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU
        CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE.,
     &  MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA,
     &  LRLU, IPTRLU,IWPOS,IWPOSCB,
     &  PTRIST,PTRAST,STEP, PIMASTER, PAMASTER,
     &  LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE.,
     &  COMP, LRLUS, IFLAG, IERROR
     &     )
        IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU
        IF ( IFLAG .LT. 0 ) RETURN
        PIMASTER(STEP( FINODE )) = IWPOSCB + 1
        PAMASTER(STEP( FINODE )) = IPTRLU  + 1_8
        IF (COMPRESSCB)  IW(IWPOSCB + 1 + XXS ) = S_CB1COMP
        CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &        IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ),
     &        MPI_INTEGER, COMM, IERR)
      ENDIF
      IF (COMPRESSCB) THEN
        ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) *
     &                  int(NBROWS_ALREADY_SENT+1,8) / 2_8
        SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 +
     &                 NBROWS_ALREADY_SENT * NBROWS_PACKET
      ELSE
        ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8)
        SIZE_PACKET = NBROWS_PACKET * FLCONT
      ENDIF
      IF (NBROWS_PACKET.NE.0) THEN
        IF ( LREQCB .ne. 0_8 ) THEN
        IPOS_NODE = PAMASTER(STEP(FINODE))-1_8
        CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION,
     &        A(IPOS_NODE + 1_8 + ISHIFT_PACKET),
     &        SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR)
        END IF
      ENDIF
      IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN
        NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1
        IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN
          FLAG = . TRUE.
        END IF
      ENDIF
      RETURN
      END SUBROUTINE ZMUMPS_PROCESS_NODE