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_LAST_RTNELIND( COMM_LOAD, ASS_IRECV, 14 & root, FRERE, IROOT, 15 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 16 & IWPOS, IWPOSCB, IPTRLU, 17 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 18 & PTLUST_S, PTRFAC, 19 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 20 & IFLAG, IERROR, COMM, 21 & NBPROCFILS, 22 & IPOOL, LPOOL, LEAF, 23 & NBFIN, MYID, SLAVEF, 24 & 25 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 26 & FILS, PTRARW, PTRAIW, 27 & INTARR, DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND, 28 & LPTRAR, NELT, FRTPTR, FRTELT, 29 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 30 & , LRGROUPS 31 & ) 32 USE DMUMPS_BUF 33 IMPLICIT NONE 34 INCLUDE 'dmumps_root.h' 35 INCLUDE 'mpif.h' 36 TYPE (DMUMPS_ROOT_STRUC) :: root 37 INTEGER IROOT 38 INTEGER ICNTL( 40 ), KEEP( 500 ) 39 INTEGER(8) KEEP8(150) 40 DOUBLE PRECISION DKEEP(230) 41 INTEGER COMM_LOAD, ASS_IRECV 42 INTEGER LBUFR, LBUFR_BYTES 43 INTEGER BUFR( LBUFR ) 44 INTEGER(8) :: POSFAC,IPTRLU, LRLU, LRLUS 45 INTEGER IWPOS, IWPOSCB 46 INTEGER(8) :: LA 47 INTEGER N, LIW 48 INTEGER IW( LIW ) 49 DOUBLE PRECISION A( LA ) 50 INTEGER, intent(in) :: LRGROUPS(N) 51 INTEGER(8) :: PTRAST(KEEP(28)) 52 INTEGER(8) :: PTRFAC(KEEP(28)) 53 INTEGER(8) :: PAMASTER(KEEP(28)) 54 INTEGER PTRIST(KEEP(28)), PTLUST_S(KEEP(28)) 55 INTEGER STEP(N), PIMASTER(KEEP(28)) 56 INTEGER COMP 57 INTEGER NSTK_S( KEEP(28) ), PROCNODE_STEPS( KEEP(28) ) 58 INTEGER NBPROCFILS( KEEP(28) ) 59 INTEGER IFLAG, IERROR, COMM 60 INTEGER LPTRAR, NELT 61 INTEGER FRTPTR( N+1 ), FRTELT( NELT ) 62 INTEGER LPOOL, LEAF 63 INTEGER IPOOL( LPOOL ) 64 INTEGER MYID, SLAVEF, NBFIN 65 INTEGER ISTEP_TO_INIV2(KEEP(71)), 66 & TAB_POS_IN_PERE(SLAVEF+2,max(1,KEEP(56))) 67 DOUBLE PRECISION OPASSW, OPELIW 68 INTEGER ITLOC( N+KEEP(253) ), FILS( N ) 69 DOUBLE PRECISION :: RHS_MUMPS(KEEP(255)) 70 INTEGER(8), INTENT(IN) :: PTRARW( LPTRAR ), PTRAIW( LPTRAR ) 71 INTEGER ND(KEEP(28)), FRERE(KEEP(28)) 72 DOUBLE PRECISION DBLARR( KEEP8(26) ) 73 INTEGER INTARR( KEEP8(27) ) 74 INTEGER I, NELIM, NB_CONTRI_GLOBAL, NUMORG, 75 & NFRONT, IROW, JCOL, PDEST, HF, IOLDPS, 76 & IN, DEB_ROW, ILOC_ROW, IFSON, ILOC_COL, 77 & IPOS_SON, NELIM_SON, NSLAVES_SON, HS, 78 & IROW_SON, ICOL_SON, ISLAVE, IERR, 79 & NELIM_SENT, IPOS_STATREC, TYPE_SON 80 INTEGER MUMPS_PROCNODE 81 EXTERNAL MUMPS_PROCNODE 82 INCLUDE 'mumps_headers.h' 83 INCLUDE 'mumps_tags.h' 84 NB_CONTRI_GLOBAL = KEEP(41) 85 NUMORG = root%ROOT_SIZE 86 NELIM = KEEP(42) 87 NFRONT = NUMORG + KEEP(42) 88 DO IROW = 0, root%NPROW - 1 89 DO JCOL = 0, root%NPCOL - 1 90 PDEST = IROW * root%NPCOL + JCOL 91 IF ( PDEST .NE. MYID ) THEN 92 CALL DMUMPS_BUF_SEND_ROOT2SLAVE(NFRONT, 93 & NB_CONTRI_GLOBAL, PDEST, COMM, KEEP, IERR) 94 if (IERR.lt.0) then 95 write(6,*) ' error detected by ', 96 & 'DMUMPS_BUF_SEND_ROOT2SLAVE' 97 CALL MUMPS_ABORT() 98 endif 99 ENDIF 100 END DO 101 END DO 102 CALL DMUMPS_PROCESS_ROOT2SLAVE( NFRONT, 103 & NB_CONTRI_GLOBAL, root, 104 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 105 & IWPOS, IWPOSCB, IPTRLU, 106 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 107 & PTLUST_S, PTRFAC, 108 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 109 & IFLAG, IERROR, COMM, COMM_LOAD, 110 & NBPROCFILS, 111 & IPOOL, LPOOL, LEAF, 112 & NBFIN, MYID, SLAVEF, 113 & 114 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 115 & FILS, PTRARW, PTRAIW, 116 & INTARR,DBLARR,ICNTL,KEEP,KEEP8,DKEEP,ND ) 117 IF (IFLAG < 0 ) RETURN 118 HF = 6 + KEEP(IXSZ) 119 IOLDPS = PTLUST_S(STEP(IROOT)) 120 IN = IROOT 121 DEB_ROW = IOLDPS + HF 122 ILOC_ROW = DEB_ROW 123 DO WHILE (IN.GT.0) 124 IW(ILOC_ROW) = IN 125 IW(ILOC_ROW+NFRONT) = IN 126 ILOC_ROW = ILOC_ROW + 1 127 IN = FILS(IN) 128 END DO 129 IFSON = -IN 130 ILOC_ROW = IOLDPS + HF + NUMORG 131 ILOC_COL = ILOC_ROW + NFRONT 132 IF ( NELIM.GT.0 ) THEN 133 IN = IFSON 134 DO WHILE (IN.GT.0) 135 IPOS_SON = PIMASTER(STEP(IN)) 136 IF (IPOS_SON .EQ. 0) GOTO 100 137 NELIM_SON = IW(IPOS_SON+1+KEEP(IXSZ)) 138 if (NELIM_SON.eq.0) then 139 write(6,*) ' error 1 in process_last_rtnelind' 140 CALL MUMPS_ABORT() 141 endif 142 NSLAVES_SON = IW(IPOS_SON+5+KEEP(IXSZ)) 143 HS = 6 + NSLAVES_SON + KEEP(IXSZ) 144 IROW_SON = IPOS_SON + HS 145 ICOL_SON = IROW_SON + NELIM_SON 146 DO I = 1, NELIM_SON 147 IW( ILOC_ROW+I-1 ) = IW( IROW_SON+I-1 ) 148 ENDDO 149 DO I = 1, NELIM_SON 150 IW( ILOC_COL+I-1 ) = IW( ICOL_SON+I-1 ) 151 ENDDO 152 NELIM_SENT = ILOC_ROW - IOLDPS - HF + 1 153 DO ISLAVE = 0,NSLAVES_SON 154 IF (ISLAVE.EQ.0) THEN 155 PDEST= MUMPS_PROCNODE(PROCNODE_STEPS(STEP(IN)),SLAVEF) 156 ELSE 157 PDEST = IW(IPOS_SON + 5 + ISLAVE+KEEP(IXSZ)) 158 ENDIF 159 IF (PDEST.NE.MYID) THEN 160 CALL DMUMPS_BUF_SEND_ROOT2SON(IN, NELIM_SENT, 161 & PDEST, COMM, KEEP, IERR ) 162 if (IERR.lt.0) then 163 write(6,*) ' error detected by ', 164 & 'DMUMPS_BUF_SEND_ROOT2SLAVE' 165 CALL MUMPS_ABORT() 166 endif 167 ELSE 168 CALL DMUMPS_PROCESS_ROOT2SON( COMM_LOAD, ASS_IRECV, 169 & IN, NELIM_SENT, root, 170 & 171 & BUFR, LBUFR, LBUFR_BYTES, PROCNODE_STEPS, POSFAC, 172 & IWPOS, IWPOSCB, IPTRLU, 173 & LRLU, LRLUS, N, IW, LIW, A, LA, PTRIST, 174 & PTLUST_S, PTRFAC, 175 & PTRAST, STEP, PIMASTER, PAMASTER, NSTK_S, COMP, 176 & IFLAG, IERROR, COMM, 177 & NBPROCFILS, 178 & IPOOL, LPOOL, LEAF, 179 & NBFIN, MYID, SLAVEF, 180 & 181 & OPASSW, OPELIW, ITLOC, RHS_MUMPS, 182 & FILS, PTRARW, PTRAIW, 183 & INTARR, DBLARR, ICNTL, KEEP, KEEP8, DKEEP, ND, FRERE, 184 & LPTRAR, NELT, FRTPTR, FRTELT, 185 & ISTEP_TO_INIV2, TAB_POS_IN_PERE 186 & , LRGROUPS 187 & ) 188 IF ( ISLAVE .NE. 0 ) THEN 189 IF (KEEP(50) .EQ. 0) THEN 190 IPOS_STATREC = PTRIST(STEP(IN))+6+KEEP(IXSZ) 191 ELSE 192 IPOS_STATREC = PTRIST(STEP(IN))+8+KEEP(IXSZ) 193 ENDIF 194 IF (IW(IPOS_STATREC).EQ. S_REC_CONTSTATIC) THEN 195 IW(IPOS_STATREC) = S_ROOT2SON_CALLED 196 ELSE 197 IF (NSLAVES_SON .EQ. 0) THEN 198 TYPE_SON = 1 199 ELSE 200 TYPE_SON = 2 201 ENDIF 202 CALL DMUMPS_FREE_BAND( N, IN, PTRIST, PTRAST, 203 & IW, LIW, A, LA, LRLU, LRLUS, IWPOSCB, 204 & IPTRLU, STEP, MYID, KEEP, KEEP8, TYPE_SON 205 & ) 206 ENDIF 207 ENDIF 208 IPOS_SON = PIMASTER(STEP(IN)) 209 ENDIF 210 END DO 211 CALL DMUMPS_FREE_BLOCK_CB( .FALSE.,MYID,N, IPOS_SON, 212 & PTRAST(STEP(IN)), 213 & IW, LIW, 214 & LRLU, LRLUS, IPTRLU, 215 & IWPOSCB, LA, KEEP,KEEP8, .FALSE. 216 & ) 217 ILOC_ROW = ILOC_ROW + NELIM_SON 218 ILOC_COL = ILOC_COL + NELIM_SON 219 100 CONTINUE 220 IN = FRERE(STEP(IN)) 221 ENDDO 222 ENDIF 223 RETURN 224 END SUBROUTINE DMUMPS_LAST_RTNELIND 225