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_PROCESS_NODE( MYID,KEEP,KEEP8,DKEEP, 14 & BUFR, LBUFR, LBUFR_BYTES, 15 & IWPOS, IWPOSCB, IPTRLU, LRLU, LRLUS, 16 & N, IW, LIW, A, LA, 17 & PTRIST, PTRAST, STEP, PIMASTER, PAMASTER, 18 & NSTK_S, COMP, 19 & FPERE, FLAG, IFLAG, IERROR, COMM, 20 & ITLOC, RHS_MUMPS ) 21 IMPLICIT NONE 22 INCLUDE 'mpif.h' 23 INTEGER IERR 24 INTEGER MYID 25 INTEGER LBUFR, LBUFR_BYTES 26 INTEGER KEEP(500), BUFR( LBUFR ) 27 INTEGER(8) KEEP8(150) 28 DOUBLE PRECISION DKEEP(230) 29 INTEGER(8) :: LA, IPTRLU, LRLU, LRLUS 30 INTEGER IWPOS, IWPOSCB 31 INTEGER N, LIW 32 INTEGER IW( LIW ) 33 COMPLEX(kind=8) A( LA ) 34 INTEGER(8) :: PTRAST (KEEP(28)) 35 INTEGER(8) :: PAMASTER(KEEP(28)) 36 INTEGER PTRIST( KEEP(28) ) 37 INTEGER STEP(N), PIMASTER(KEEP(28)) 38 INTEGER COMP, FPERE 39 LOGICAL FLAG 40 INTEGER NSTK_S( KEEP(28) ), ITLOC( N + KEEP(253) ) 41 COMPLEX(kind=8) :: RHS_MUMPS(KEEP(255)) 42 INTEGER IFLAG, IERROR, COMM 43 INTEGER POSITION, FINODE, FLCONT, LREQ 44 INTEGER(8) :: LREQCB 45 INTEGER(8) :: IPOS_NODE, ISHIFT_PACKET 46 INTEGER SIZE_PACKET 47 INTEGER NBROWS_ALREADY_SENT, NBROWS_PACKET 48 INCLUDE 'mumps_headers.h' 49 LOGICAL COMPRESSCB 50 FLAG = .FALSE. 51 POSITION = 0 52 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 53 & FINODE, 1, MPI_INTEGER, 54 & COMM, IERR) 55 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 56 & FPERE, 1, MPI_INTEGER, 57 & COMM, IERR) 58 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 59 & FLCONT, 1, MPI_INTEGER, 60 & COMM, IERR) 61 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 62 & NBROWS_ALREADY_SENT, 1, MPI_INTEGER, 63 & COMM, IERR) 64 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 65 & NBROWS_PACKET, 1, MPI_INTEGER, 66 & COMM, IERR) 67 COMPRESSCB = (FLCONT.LT.0) 68 IF (COMPRESSCB) THEN 69 FLCONT = -FLCONT 70 LREQCB = (int(FLCONT,8) * int(FLCONT+1,8)) / 2_8 71 ELSE 72 LREQCB = int(FLCONT,8) * int(FLCONT,8) 73 ENDIF 74 IF (NBROWS_ALREADY_SENT == 0) THEN 75 LREQ = 2 * FLCONT + 6 + KEEP(IXSZ) 76 IF (IPTRLU.LT.0_8) WRITE(*,*) 'before alloc_cb:IPTRLU = ',IPTRLU 77 CALL ZMUMPS_ALLOC_CB( .FALSE., 0_8, .FALSE.,.FALSE., 78 & MYID,N, KEEP,KEEP8, DKEEP, IW, LIW, A, LA, 79 & LRLU, IPTRLU,IWPOS,IWPOSCB, 80 & PTRIST,PTRAST,STEP, PIMASTER, PAMASTER, 81 & LREQ, LREQCB, FINODE, S_NOTFREE, .TRUE., 82 & COMP, LRLUS, IFLAG, IERROR 83 & ) 84 IF (IPTRLU.LT.0_8) WRITE(*,*) 'after alloc_cb:IPTRLU = ',IPTRLU 85 IF ( IFLAG .LT. 0 ) RETURN 86 PIMASTER(STEP( FINODE )) = IWPOSCB + 1 87 PAMASTER(STEP( FINODE )) = IPTRLU + 1_8 88 IF (COMPRESSCB) IW(IWPOSCB + 1 + XXS ) = S_CB1COMP 89 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 90 & IW(IWPOSCB + 1+KEEP(IXSZ)), LREQ-KEEP(IXSZ), 91 & MPI_INTEGER, COMM, IERR) 92 ENDIF 93 IF (COMPRESSCB) THEN 94 ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * 95 & int(NBROWS_ALREADY_SENT+1,8) / 2_8 96 SIZE_PACKET = (NBROWS_PACKET * (NBROWS_PACKET+1))/2 + 97 & NBROWS_ALREADY_SENT * NBROWS_PACKET 98 ELSE 99 ISHIFT_PACKET = int(NBROWS_ALREADY_SENT,8) * int(FLCONT,8) 100 SIZE_PACKET = NBROWS_PACKET * FLCONT 101 ENDIF 102 IF (NBROWS_PACKET.NE.0) THEN 103 IF ( LREQCB .ne. 0_8 ) THEN 104 IPOS_NODE = PAMASTER(STEP(FINODE))-1_8 105 CALL MPI_UNPACK(BUFR, LBUFR_BYTES, POSITION, 106 & A(IPOS_NODE + 1_8 + ISHIFT_PACKET), 107 & SIZE_PACKET, MPI_DOUBLE_COMPLEX, COMM, IERR) 108 END IF 109 ENDIF 110 IF (NBROWS_ALREADY_SENT+NBROWS_PACKET == FLCONT) THEN 111 NSTK_S(STEP(FPERE)) = NSTK_S(STEP(FPERE)) - 1 112 IF ( NSTK_S(STEP(FPERE)).EQ.0 ) THEN 113 FLAG = . TRUE. 114 END IF 115 ENDIF 116 RETURN 117 END SUBROUTINE ZMUMPS_PROCESS_NODE 118