1 : C PILEPS SOURCE PV 09/03/12 21:30:12 6325 2 : SUBROUTINE PILEPS 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : * 6 : * but : soit deux champs de epsilon il faut trouver le lambda max 7 : * tel que: eps1 + lambda*eps2 = signe(eps2) * crit 8 : * 9 : -INC SMCHAML 10 : -INC SMLREEL 11 : -INC CCOPTIO 12 : SEGMENT MZONG 13 : INTEGER NZONG(0) 14 : ENDSEGMENT 15 : SEGMENT MZON1 16 : INTEGER NZON1(0) 17 : ENDSEGMENT 18 : SEGMENT MZON2 19 : INTEGER NZON2(0) 20 : ENDSEGMENT 21 : SEGMENT ITAFF 22 : INTEGER JTAFF(0) 23 : ENDSEGMENT 24 : SEGMENT NOMID 25 : CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC) 26 : ENDSEGMENT 27 : SEGMENT MPTVAL 28 : INTEGER IPOS(NS) ,NSOF(NS) 29 : INTEGER IVAL(NCOSOU) 30 : CHARACTER*16 TYVAL(NCOSOU) 31 : ENDSEGMENT 32 : PARAMETER ( NINF=3 ) 33 : INTEGER INFOS(NINF) 34 : CHARACTER*72 MOT 35 : CHARACTER*16 CONCH1,CONCH2 36 : * lecture des champs et du flottant 36 : CALL LIROBJ('MCHAML ',IPCHE1,1,IRETOU) 37 : IF(IERR.NE.0) RETURN 37 : CALL LIROBJ('MCHAML ',IPCHE2,1,IRETOU) 38 : IF(IERR.NE.0) RETURN 38 : CALL LIRREE(XCRIT,1,IRETOU) 39 : IF(IERR.NE.0) RETURN 40 : * fin de lecture 41 : XLAMB=1.D30 42 : IF(IPCHE1.NE.IPCHE2) GOTO 1000 43 : * 44 : * SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL 45 : * 46 : MCHELM=IPCHE1 47 : SEGACT MCHELM 48 : NSOUS = IMACHE(/1) 49 : * 50 : DO 110 IA=1,NSOUS 51 : MCHAML=ICHAML(IA) 52 : SEGACT MCHAML 53 : ICHAML(IA)=MCHAML 54 : DO 111 ICOMP=1,IELVAL(/1) 55 : MELVAL = IELVAL(ICOMP) 56 : SEGACT MELVAL 57 : N1PTEL=VELCHE(/1) 58 : IF (N1PTEL.EQ.0) THEN 58 : CALL ERREUR(19) 59 : SEGDES MELVAL,MCHAML, MCHELM 60 : RETURN 61 : ELSE 62 : N1EL=VELCHE(/2) 63 : DO 5 IGAU=1,N1PTEL 64 : XLA = 1.D50 65 : DO 5 IB=1,N1EL 66 : IF( VELCHE(IGAU,IB) .NE. 0. ) 67 : * XLA=(SIGN( XCRIT,VELCHE(IGAU,IB))- VELCHE(IGAU,IB)) 68 : * /VELCHE(IGAU,IB) 69 : IF ( XLA.LE.XLAMB ) XLAMB = XLA 70 : 5 CONTINUE 71 : ENDIF 72 : SEGDES MELVAL 73 : 111 CONTINUE 74 : SEGDES MCHAML 75 : 110 CONTINUE 76 : SEGDES MCHELM 77 : GOTO 777 78 : * 79 : * CAS GENERAL 80 : * 81 : 1000 CONTINUE 82 : MCHEL1=IPCHE1 83 : MCHEL2=IPCHE2 84 : SEGACT MCHEL1 85 : SEGACT MCHEL2 86 : IF(MCHEL1.IFOCHE.EQ.MCHEL2.IFOCHE) GOTO 3000 87 : * 88 : * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS 89 : * DE SS TYPE DIFFERENTS 90 : * 91 : MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8) 91 : CALL ERREUR(99) 92 : IPCHAD=0 93 : GOTO 666 94 : *_______________________________________________________________________ 95 : * 96 : * CAS GENERAL 97 : *_______________________________________________________________________ 98 : * 99 : 3000 CONTINUE 100 : N3=MCHEL1.INFCHE(/2) 101 : NSOUS1=MCHEL1.ICHAML(/1) 102 : NSOUS2=MCHEL2.ICHAML(/1) 103 : * 104 : * QUELLES BIJECTIONS ENTRE LES SOUS PAQUETS SI OUI TRAITEMENT AMELIORE 105 : * 106 : IF(NSOUS1.NE.NSOUS2) GOTO 4000 107 : * 108 : SEGINI ITAFF 109 : DO 17 ISOUS1=1,NSOUS1 110 : IPMAI1 = MCHEL1.IMACHE(ISOUS1) 111 : CONCH1 = MCHEL1.CONCHE(ISOUS1) 112 : DO 18 ISOUS2=1,NSOUS2 113 : ISOUS=ISOUS2 114 : IPMAI2= MCHEL2.IMACHE(ISOUS) 115 : CONCH2= MCHEL2.CONCHE(ISOUS) 116 : IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN 117 : * 118 : * VERIFICATION POUR LES INFCHE 119 : * 119 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 120 : IF (IRTD.EQ.0) GOTO 18 121 : IMINT1=0 122 : IMINT2=0 123 : IF (MCHEL1.INFCHE(/2).GE.4) IMINT1=MCHEL1.INFCHE(ISOUS1,4) 124 : IF (MCHEL2.INFCHE(/2).GE.4) IMINT2=MCHEL2.INFCHE(ISOUS2,4) 125 : IF (IMINT1.EQ.IMINT2) GOTO 171 126 : IMINT1=1 127 : IMINT2=1 128 : IF (MCHEL1.INFCHE(/2).GE.6) IMINT1=MCHEL1.INFCHE(ISOUS1,6) 129 : IF (MCHEL2.INFCHE(/2).GE.6) IMINT2=MCHEL2.INFCHE(ISOUS2,6) 130 : IF (IMINT1.EQ.0) IMINT1=1 131 : IF (IMINT2.EQ.0) IMINT2=1 132 : IF (IMINT1.EQ.IMINT2) GOTO 171 133 : * 134 : * ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS 135 : * DE SS TYPE DIFFERENTS 136 : * 136 : CALL ERREUR(19) 137 : SEGDES MCHEL1,MCHEL2 138 : SEGSUP ITAFF 139 : RETURN 140 : ENDIF 141 : 18 CONTINUE 142 : SEGSUP ITAFF 143 : GOTO 4000 144 : * 145 : 171 CONTINUE 146 : JTAFF(**)=MCHEL2.ICHAML(ISOUS) 147 : 17 CONTINUE 148 : * 149 : * ON A TROUVE UNE BIJECTION ET ON VECTORISE 150 : * 151 : N1=NSOUS1 152 : DO 400 ISOUS=1,NSOUS1 153 : 154 : MCHAML=MCHEL1.ICHAML(ISOUS) 155 : * 156 : SEGACT MCHAML 157 : IPCHA=MCHAML 158 : * 159 : MCHAM2=JTAFF(ISOUS) 160 : SEGACT MCHAM2 161 : IPCHA2=MCHAM2 162 : * 162 : CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT) 163 : IF (IPCHA.EQ.0) THEN 164 : SEGSUP ITAFF 165 : GOTO 9990 166 : ENDIF 167 : * 168 : SEGDES MCHAML,MCHAM2 169 : 400 CONTINUE 170 : SEGDES MCHEL1,MCHEL2 171 : SEGSUP ITAFF 172 : GOTO 777 173 : *_______________________________________________________________________ 174 : * 175 : * ON A PAS TROUVE DE BIJECTION 176 : *_______________________________________________________________________ 177 : * 178 : 4000 CONTINUE 179 : SEGINI MZONG,MZON1,MZON2 180 : DO 500 ISOUS1=1,NSOUS1 181 : NZONG(**)=MCHEL1.IMACHE(ISOUS1) 182 : NZON1(**)=ISOUS1 183 : NZON2(**)=0 184 : 500 CONTINUE 185 : IWRN=0 186 : DO 510 ISOUS2=1,NSOUS2 187 : IPMAI2 = MCHEL2.IMACHE(ISOUS2) 188 : CONCH2 = MCHEL2.CONCHE(ISOUS2) 189 : DO 520 ISOUS1=1,NSOUS1 190 : IPMAI1= MCHEL1.IMACHE(ISOUS1) 191 : CONCH1= MCHEL1.CONCHE(ISOUS1) 192 : IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN 192 : CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD) 193 : IF (IRTD.EQ.0) GOTO 520 194 : * 195 : * VERIFICATION POUR LES MINTES 196 : * 197 : IF ( MCHEL1.INFCHE(ISOUS1,4).EQ. 198 : & MCHEL2.INFCHE(ISOUS2,4) ) GOTO 530 199 : * 200 : * ERREUR SUR LES SUPPORTS DES MCHAML 201 : * 201 : CALL ERREUR(19) 202 : SEGDES MCHEL1,MCHEL2 203 : SEGSUP MZONG,MZON1,MZON2 204 : RETURN 205 : * 206 : ENDIF 207 : 520 CONTINUE 208 : IWRN=1 209 : NZONG(**)=IPMAI2 210 : NZON1(**)=0 211 : NZON2(**)=ISOUS2 212 : GOTO 510 213 : * 214 : 530 CONTINUE 215 : NZON2(ISOUS1)=ISOUS2 216 : 510 CONTINUE 217 : * 218 : * WARNING LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2 219 : * 219 : IF(IWRN.EQ.1) CALL ERREUR(103) 220 : NSOUS=NZONG(/1) 221 : N1=NSOUS 222 : * 223 : DO 540 ISOUS=1,NSOUS 224 : IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550 225 : * 226 : IF(NZON1(ISOUS).NE.0) THEN 227 : MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) ) 228 : SEGACT MCHAML 229 : ENDIF 230 : IF(NZON2(ISOUS).NE.0) THEN 231 : MCHAML=MCHEL2.ICHAML( NZON2(ISOUS) ) 232 : SEGACT MCHAML 233 : ENDIF 234 : * 235 : * 236 : GOTO 540 237 : * 238 : 550 CONTINUE 239 : MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) ) 240 : SEGACT MCHAML 241 : IPCHAD=MCHAML 242 : MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) ) 243 : SEGACT MCHAM2 244 : IPCHA2=MCHAM2 245 : * 245 : CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT) 246 : IF (IPCHA.EQ.0) THEN 247 : SEGSUP MZONG,MZON1,MZON2 248 : GOTO 9990 249 : ENDIF 250 : * 251 : SEGDES MCHAML,MCHAM2 252 : 540 CONTINUE 253 : * 254 : SEGSUP MZONG,MZON1,MZON2 255 : GOTO 666 256 : * 257 : 9990 CONTINUE 258 : * 259 : * ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR 260 : * 261 : SEGDES MCHEL1,MCHEL2,MCHAM2, MCHAML 262 : SEGSUP ITAFF 263 : 264 : RETURN 265 : * 266 : 666 CONTINUE 267 : SEGDES MCHEL1,MCHEL2 268 : 777 CONTINUE 268 : CALL ECRREE ( XLAMB) 269 : RETURN 270 : END 271 : 272 : 273 : 274 : 275 :
© Cast3M 2003 - All rights reserved.
Disclaimer