1 : C CORRSP SOURCE PV 13/04/30 21:15:00 7772 2 : SUBROUTINE CORRSP(ipr,IPVEC,IPMX,IPLMOX,IPLMOY) 3 : C 4 : C********************************************************************** 5 : C 6 : C CE SP APPELE PAR ITINV, SIMUL1 ... PREPARE L OBJET 'LISTMOTS' 7 : C NECESSAIRE A L OPERATEUR XTY : COUPLE DES NOMS D INCONNUES A 8 : c ASSOCIER 9 : C 10 : C IPR : pointeur sur l'objet RIGIDITE qui définit la dualité 11 : C IPVEC : OBJET DE TYPE CHPOINT 12 : C IPMX : OBJET DE TYPE CHPOINT 13 : C IPLMOX : POINTEUR SUR OBJET LISTMOTS UX,UY.... 14 : C IPLMOY : POINTEUR SUR OBJET LISTMOTS FX,FY.... 15 : C 16 : C AUTEUR : D.BROCHARD 17 : C DATE : 11/01/88 18 : C 19 : C BP , novembre 2010 : on supprime l hypothese selon laquelle : 20 : c " la matrice possede des correspondances sur les inconnues 21 : c (c'est a dire que la ieme ligne est la duale de la ieme colonne) " 22 : C => On utilise NOMDD et NOMDU de CCHAMP pour créer l'association 23 : C "naturelle" entre les inconnues primales et duales (permet dutiliser 24 : C de matrices creuses commes celles crees par imped par ex.) 25 : C 26 : C********************************************************************* 27 : C 28 : C 29 : IMPLICIT INTEGER(I-N) 30 : IMPLICIT REAL*8(A-H,O-Z) 31 : CHARACTER*4 NOCO 32 : C 33 : -INC CCOPTIO 34 : -INC CCHAMP 35 : -INC SMLMOTS 36 : -INC SMCHPOI 37 : -INC SMRIGID 38 : C 39 : C 40 : pointeur lmopri.mlmots, lmodua.mlmots 41 : 42 : iplmox=0 43 : iplmoy=0 44 : C 45 : C==== CREATION DE lmopri lmodua QUI DEFINIT LA REGLE D'ASSOCIATION ==== 46 : C 47 : C CREATION BASEE SUR NOMDD et NOMDU de CCHAMP rempli dans bdata.eso 48 : C 49 : jgn=4 50 : jgm=LNOMDD 51 : segini,lmopri 52 : segini,lmodua 53 : do i=1,jgm 54 : lmopri.mots(i)=NOMDD(i) 55 : lmodua.mots(i)=NOMDU(i) 56 : enddo 57 : c C 58 : c C CREATION BASEE SUR LA MATRICE FOURNIE (ancienne syntaxe) 59 : c C 60 : mrigid=ipr 61 : segact,mrigid 62 : nbriel=irigel(/2) 63 : if (irigel(/1).lt.3) then 64 : write(*,*) 'CORRSP: Information insuffisante dans la RIGIDITE' 65 : segdes,mrigid 66 : return 67 : endif 68 : itaill=0 69 : do 1 i=1,nbriel 70 : descr=irigel(3,i) 71 : segact,descr 72 : nbcpri=lisinc(/2) 73 : nbcdua=lisdua(/2) 74 : if(nbcpri.ne.nbcdua) then 75 : * write(*,*) 'CORRSP: Zone',i,' de la RIGIDITE contient des', 76 : * & ' matrices non carrées !!!' 77 : segdes,descr 78 : goto 1 79 : endif 80 : do 2 ic=1,nbcpri 81 : if (lisinc(ic).eq.lisdua(ic)) goto 2 82 : do 6 ij=1,jgm 83 : if (lmopri.mots(ij).ne.lisinc(ic)) goto 6 84 : if (lmodua.mots(ij).eq.lisdua(ic)) goto 2 85 : moterr(1:4) = lmopri.mots(ij) 86 : moterr(5:8) = lmodua.mots(ij) 87 : moterr(9:12)= lisdua(ic) 87 : call erreur(1026) 88 : 6 continue 89 : if (jgm.eq.0) then 90 : jgm=1 91 : segadj,lmopri 92 : segadj,lmodua 93 : lmopri.mots(1)=lisinc(ic) 94 : lmodua.mots(1)=lisdua(ic) 95 : else 96 : do 3 ica=1,jgm 97 : if(lmopri.mots(ica).eq.lisinc(ic)) goto 2 98 : 3 continue 99 : jgm=jgm+1 100 : segadj,lmopri 101 : segadj,lmodua 102 : lmopri.mots(jgm)=lisinc(ic) 103 : lmodua.mots(jgm)=lisdua(ic) 104 : endif 105 : 2 continue 106 : segdes,descr 107 : 1 continue 108 : segdes,mrigid 109 : c 110 : itaill=jgm 111 : 112 : if (iimpi.eq.321) then 113 : do 4 i=1,itaill 114 : write(*,*) lmopri.mots(i),' <=> ',lmodua.mots(i) 115 : 4 continue 116 : endif 117 : C 118 : C 119 : C==== CREATION et REMPLISSAGE DE MLMOTS MLMOT2 (= RESULTATS) ==== 120 : C 121 : JGN=4 122 : JGM=0 123 : SEGINI MLMOTS 124 : SEGINI MLMOT2 125 : C 126 : C ON UTILISE LE CHPOINT PRIMAL 127 : INU=0 128 : MCHPO1=IPVEC 129 : SEGACT MCHPO1 130 : NSOUP1=MCHPO1.IPCHP(/1) 131 : C 132 : DO 10 ISOUP1 = 1,NSOUP1 133 : MSOUP1 = MCHPO1.IPCHP(ISOUP1) 134 : SEGACT MSOUP1 135 : NC1 = MSOUP1.NOCOMP(/2) 136 : DO 20 NCI = 1,NC1 137 : C 138 : IF(IIMPI.EQ.321) WRITE(IOIMP,*) NCI,MSOUP1.NOCOMP(NCI) 139 : C 140 : IF(INU.NE.0) GOTO 30 141 : NOCO = MSOUP1.NOCOMP(1) 141 : CALL PLACE(lmopri.mots(1),itaill,IPLA,NOCO) 142 : if(ipla.eq.0) goto 20 143 : JGM=JGM+1 144 : SEGADJ MLMOTS 145 : SEGADJ MLMOT2 146 : MOTS(JGM) = NOCO 147 : MLMOT2.MOTS(JGM) = lmodua.mots(IPLA) 148 : INU = INU+1 149 : GOTO 20 150 : C 151 : 30 CONTINUE 152 : NOCO = MSOUP1.NOCOMP(NCI) 153 : DO 40 I =1,INU 154 : IF(NOCO.EQ.MOTS(I)) GOTO 20 155 : 40 CONTINUE 155 : CALL PLACE(lmopri.mots(1),itaill,IPLA,NOCO) 156 : if (ipla.eq.0) goto 20 157 : INU =INU+1 158 : JGM=JGM+1 159 : SEGADJ MLMOTS 160 : SEGADJ MLMOT2 161 : MOTS(JGM) = NOCO 162 : MLMOT2.MOTS(JGM)= lmodua.mots(IPLA) 163 : 20 CONTINUE 164 : SEGDES MSOUP1 165 : 10 CONTINUE 166 : SEGDES MCHPO1 167 : C 168 : IPLMOX=MLMOTS 169 : IPLMOY=MLMOT2 170 : C 171 : C 172 : C==== VERIFICATION : 173 : C LES VARIABLES SONT ELLES BIEN DANS LE CHPOINT DUAL 174 : c 175 : c rem : il s agit seulement d un message informatif 176 : c pas d une erreur car on peut avoir u={UX RX LX} 177 : c et M*u={FX } seulement ! 178 : c ca ne derange pas xty1 a priori... 179 : c IF(IIMPI.lt.5) GOTO 999 180 : c 181 : c on peut faire mieux en enlevant les couples "veufs" 182 : 183 : C==== CREATION et REMPLISSAGE DE MLMOT1 ==== 184 : JGM=0 185 : SEGINI MLMOT1 186 : IMU=0 187 : MCHPOI=IPMX 188 : SEGACT MCHPOI 189 : NSOUPO=IPCHP(/1) 190 : DO 100 ISOUPO=1,NSOUPO 191 : C 192 : MSOUPO=IPCHP(ISOUPO) 193 : SEGACT MSOUPO 194 : NC1 = NOCOMP(/2) 195 : DO 120 NCI = 1,NC1 196 : C 197 : IF(IIMPI.EQ.321) WRITE(IOIMP,*) NCI,NOCOMP(NCI) 198 : C 199 : IF (IMU.NE.0) GOTO 130 200 : NOCO = NOCOMP(1) 201 : JGM=JGM+1 202 : SEGADJ MLMOT1 203 : MLMOT1.MOTS(JGM)= NOCO 204 : IMU = IMU+1 205 : GOTO 120 206 : C 207 : 130 CONTINUE 208 : NOCO = NOCOMP(NCI) 209 : DO 140 I =1,IMU 210 : IF (NOCO.EQ.MLMOT1.MOTS(I)) GOTO 120 211 : 140 CONTINUE 212 : IMU =IMU+1 213 : JGM=JGM+1 214 : SEGADJ MLMOT1 215 : MLMOT1.MOTS(JGM) = NOCO 216 : 120 CONTINUE 217 : SEGDES MSOUPO 218 : 100 CONTINUE 219 : SEGDES MCHPOI 220 : C 221 : C==== COMPARAISON DE MLMOT1 et MLMOT2 ==== 222 : c 223 : JGM1 = MLMOT1.MOTS(/2) 224 : JGM2 = MLMOT2.MOTS(/2) 225 : JGM=0 226 : DO 200 I2=1,JGM2 227 : DO 210 I1=1,JGM1 228 : IF (MLMOT2.MOTS(I2).EQ.MLMOT1.MOTS(I1)) GOTO 199 229 : 210 CONTINUE 230 : c on n a pas retrouvé cette composante 231 : IF(IIMPI.GE.5) 232 : & WRITE(*,1000) (MLMOTS.MOTS(I2)),(MLMOT2.MOTS(I2)) 233 : 1000 FORMAT(/4X,'LA COMPOSANTE ',A4,' DUALE DE ',A4, 234 : & ' N EST PAS CONTENUE DANS LE SECOND CHPOINT') 235 : goto 200 236 : 199 CONTINUE 237 : c on a retrouvé cette composante duale 238 : JGM=JGM+1 239 : MLMOTS.MOTS(JGM)=MLMOTS.MOTS(I2) 240 : MLMOT2.MOTS(JGM)=MLMOT2.MOTS(I2) 241 : 200 CONTINUE 242 : if(JGM.ne.JGM2) segadj,MLMOTS,MLMOT2 243 : SEGSUP,MLMOT1 244 : C 245 : C==== MENAGE, MESSAGES et RETOUR ==== 246 : c 247 : 999 CONTINUE 248 : SEGDES MLMOTS,MLMOT2 249 : segsup lmopri,lmodua 250 : C 251 : IF (IIMPI.eq.321) then 252 : WRITE(IOIMP,5000) 253 : 5000 FORMAT(/10X,'SBR CORRSP',//) 253 : CALL ECLMOT(IPLMOX) 253 : CALL ECLMOT(IPLMOY) 253 : CALL ECCHPO(IPVEC,0) 253 : CALL ECCHPO(IPMX,0) 254 : endif 255 : C 256 : RETURN 257 : END 258 : 259 : 260 : 261 : 262 : 263 : 264 : 265 : 266 : 267 : 268 : 269 : 270 :
© Cast3M 2003 - All rights reserved.
Disclaimer