1 : C QUESUP SOURCE CHAT 11/03/16 21:30:00 6902 2 : SUBROUTINE QUESUP (IPMODE,IPCHE1,ISUP,ICOND,IRET,IRET2) 3 : *______________________________________________________________________ 4 : * 5 : * VERIFICATION DU LIEU SUPPORT DES MCHAML 6 : * 7 : * IPMODE POINTEUR SUR UN OBJET MODELE (UTILISE UNIQUEMENT QUAND ISUP>0) 8 : * DESACTIVE EN SORTIE 9 : * IPCHE1 POINTEUR SUR LE MCHAML DONT ON SOUHAITE VERIFIER LE SUPPORT 10 : * (LIEU DU MINTE) 11 : * ISUP > 0 : 12 : * 13 : * ISUP = 1 ON SOUHAITE QUE IPCHE1 SOIT AUX NOEUDS 14 : * = 2 ON SOUHAITE QUE IPCHE1 SOIT AUX CENTRE DE GRAVITE 15 : * = 3 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR 16 : * LA RIGIDITE 17 : * = 4 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR 18 : * LA MASSE 19 : * = 5 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR 20 : * LES CONTRAINTES 21 : * ISUP = 0 ON VEUDRAIT CONNAITRE LE SUPPORT 22 : * 23 : * ICOND = 0 SI LE MCHAML PEUT ETRE SUR LE SUPPORT DEMANDE OU AUX 24 : * NOEUDS(UTILISE UNIQUEMENT QUAND ISUP >0) 25 : * 1 SI LE MCHAML DOIT ETRE IMPERATIVEMENT SUR LE SUPPORT 26 : * VOULU (CAS NOTAMENT DES MATRICE DE HOOKES ET DES 27 : * DES MATRICES DE HOOKES TANGENTES) 28 : * DANS LE CAS ISUP > 0 29 : * 30 : * IRET = 1 IPCHE1 SE TROUVE AUX NOEUDS 31 : * = 0 IPCHE1 EST BIEN SUR LE SUPPORT DEMANDE 32 : * = 9999 LE SUPPORT DE UNE OU PLUSIEURS SOUS ZONE N'EST 33 : * PAS LE BON 34 : * DANS LE CAS ISUP = 0 35 : * 36 : * IRET > 0 IL DONNE LE NUMERO DU SUPPORT 37 : * = 0 LE CHAMP EST CONSTANT 38 : * = 9999 LE CHAMELEM N'EST PAS HOMOGENE AU NIVEAU SUPPORT 39 : * 40 : * DANS TOUS LES CAS (ISUP >= 0) 41 : * 42 : * IRET2 > 0 IL DONNE LE NUMERO DU SUPPORT 43 : * = 9999 LE CHAMELEM N'EST PAS HOMOGENE AU NIVEAU SUPPORT 44 : * OU SI LE TABLEAU INFCHE NE CONTIENT PAS CETTE 45 : * INFORMATION 46 : * 47 : * REMARQUE : SI IPCHE1 EST AUX NOEUDS LE PASSAGE DES VALEURS SUR LE 48 : * SUPPORT VOULU SE FAIT DANS VALCHE ET/OU VALMEL SAUF DANS 49 : * LE CAS DES MATRICE DE HOOKES 50 : * 51 : * CAMPENON JM LE 02/91 52 : * 53 : *pv on ne desactivee pas car ca va resservir tres bientot 54 : * 55 : *_______________________________________________________________________ 56 : * 57 : IMPLICIT INTEGER(I-N) 58 : IMPLICIT REAL*8(A-H,O-Z) 59 : -INC CCOPTIO 60 : -INC SMCHAML 61 : -INC SMINTE 62 : -INC SMMODEL 63 : * 64 : SEGMENT INFO 65 : INTEGER INFELL(JG) 66 : ENDSEGMENT 67 : * 68 : CHARACTER*16 CONCH 69 : 70 : *--------- Fin des déclarations ---------------------- 71 : 72 : IRET=0 73 : IRET2=0 74 : ICONST=1 75 : * 76 : MCHELM=IPCHE1 77 : SEGACT MCHELM 78 : NSOUS=ICHAML(/1) 79 : N3=INFCHE(/2) 80 : * 81 : * Recherche de l'information sur le support stockée dans INFCHE(*,6) ... 82 : * 83 : IF(N3.GE.6) THEN 84 : IRET2=INFCHE(1,6) 85 : DO 9 ISOUS=2,NSOUS 86 : IF(INFCHE(ISOUS,6).NE.IRET2) IRET2=9999 87 : 9 CONTINUE 88 : ELSE 89 : IRET2=9999 90 : ENDIF 91 : * 92 : * si le chamelem est constant sur l'element quelque soit le 93 : * support demande on est bon 94 : * 95 : DO 10 ISOUS=1,NSOUS 96 : MCHAML=ICHAML(ISOUS) 97 : SEGACT MCHAML 98 : NCOMP=IELVAL(/1) 99 : DO 20 ICOMP=1,NCOMP 100 : MELVAL=IELVAL(ICOMP) 101 : IF(MELVAL.NE.0)THEN 102 : SEGACT MELVAL 103 : IF(TYPCHE(ICOMP)(1:8).NE.'POINTEUR')THEN 104 : IPOIN=VELCHE(/1) 105 : ELSE 106 : IPOIN=IELCHE(/1) 107 : ENDIF 108 : IF(IPOIN.NE.1)THEN 109 : *pv SEGDES MELVAL,MCHAML 110 : ICONST=0 111 : GOTO 500 112 : ENDIF 113 : *pv SEGDES MELVAL 114 : ENDIF 115 : 20 CONTINUE 116 : *pv SEGDES MCHAML 117 : 10 CONTINUE 118 : * 119 : 500 CONTINUE 120 : IF (N3.LT.4) GOTO 1000 121 : IF(N3.GE.6) THEN 122 : ISUP1=INFCHE(1,6) 123 : IF (ICONST.EQ.1) GOTO 666 124 : ELSE 125 : GOTO 3000 126 : ENDIF 127 : * 128 : IFLAG=0 129 : * 130 : * CAS ISUP = 0 131 : * ------------ 132 : * 133 : IF(ISUP.EQ.0)THEN 134 : IF(N3.GE.6)ISUP1=INFCHE(1,6) 135 : DO 1 ISOUS=1,NSOUS 136 : * write (6,*) ' isous n3 infche4 ',isous,n3,infche(isous,4) 137 : IF (INFCHE(ISOUS,4).EQ.0) GOTO 1 138 : IF (N3.GE.6) THEN 139 : INFCH=INFCHE(ISOUS,6) 140 : * write (6,*) ' infch isup1 ',infch,isup1 141 : IF (INFCH.EQ.1) GOTO 1 142 : IF (INFCH.NE.ISUP1) THEN 143 : MINTE=INFCHE(1,4) 144 : MINTE1=INFCHE(ISOUS,4) 145 : SEGACT MINTE 146 : SEGACT MINTE1 147 : NBPGAU=POIGAU(/1) 148 : NBPGA1=MINTE1.POIGAU(/1) 149 : *pv SEGDES,MINTE,MINTE1 150 : IF(NBPGAU.EQ.NBPGA1)THEN 151 : IFLAG=IFLAG+1 152 : ELSE 153 : GOTO 2000 154 : ENDIF 155 : ELSE 156 : IFLAG=IFLAG+1 157 : ENDIF 158 : ELSE 159 : GOTO 3000 160 : ENDIF 161 : 1 CONTINUE 162 : * 163 : * TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT 164 : * 165 : IF (IFLAG.EQ.0) GOTO 1000 166 : IF (IFLAG.EQ.NSOUS) THEN 167 : IF(ISUP.EQ.0) THEN 168 : IRET=ISUP1 169 : ENDIF 170 : GOTO 666 171 : ELSE 172 : GOTO 2000 173 : ENDIF 174 : * 175 : * CAS ISUP > 0 176 : * ------------ 177 : * DANS CE CAS CE SONT LES ZONES DU MODELE QUI PILOTENT 178 : * 179 : ELSE 180 : ISUP1=ISUP 181 : * 182 : * ACTIVATION DU MODELE 183 : * 184 : MMODEL=IPMODE 185 : SEGACT MMODEL 186 : NSOUM=KMODEL(/1) 187 : DO 11 ISOUM=1,NSOUM 188 : IMODEL=KMODEL(ISOUM) 189 : SEGACT IMODEL 190 : MELE=NEFMOD 191 : if( mele.eq.22) then 192 : segdes imodel 193 : go to 11 194 : endif 195 : * 196 : * BOUCLE SUR LES ZONES DU CHAMELEM 197 : * 198 : DO 2 ISOUS=1,NSOUS 199 : CONCH=CONCHE(ISOUS) 200 : IPMAIL=IMACHE(ISOUS) 201 : * write (6,*) ' isous,imamod ipmail conch conmod infche4 ', 202 : * > isous,imamod,ipmail,conch,conmod,infche(isous,4) 203 : IF(IMAMOD.NE.IPMAIL.OR.CONCH.NE.CONMOD)GOTO 2 204 : 205 : IF (INFCHE(ISOUS,4).EQ.0) GOTO 2 206 : * 207 : IF (N3.GE.6) THEN 208 : INFCH=INFCHE(ISOUS,6) 209 : IF (INFCH.EQ.1) GOTO 2 210 : IF (INFCH.NE.ISUP1) THEN 211 : IF(ISUP1.EQ.6)THEN 211 : CALL TSHAPE(MELE,'GAUSS',IPMIN1) 212 : ELSE 213 : If(infmod(/1).lt.2+isup1) then 213 : CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL) 214 : IF(IERR.NE.0) THEN 215 : IRET=9999 216 : SEGDES IMODEL 217 : SEGDES MMODEL 218 : GOTO 666 219 : ENDIF 220 : INFO=IPINF 221 : IPMIN1=INFELL(11) 222 : segsup info 223 : else 224 : ipmin1=infmod(2+isup1) 225 : endif 226 : 227 : ENDIF 228 : MINTE=INFCHE(ISOUS,4) 229 : MINTE1=IPMIN1 230 : SEGACT MINTE 231 : SEGACT MINTE1 232 : NBPGAU=POIGAU(/1) 233 : NBPGA1=MINTE1.POIGAU(/1) 234 : IF(NBPGAU.EQ.NBPGA1)THEN 235 : IRT=1 236 : ELSE 237 : IRT=0 238 : ENDIF 239 : *pv SEGDES MINTE,MINTE1 240 : IF(IRT.EQ.1)THEN 241 : IFLAG=IFLAG+1 242 : ELSE 243 : *pv SEGDES IMODEL 244 : *pv SEGDES MMODEL 245 : GOTO 2000 246 : ENDIF 247 : ELSE 248 : IFLAG=IFLAG+1 249 : ENDIF 250 : ELSE 251 : *pv SEGDES IMODEL 252 : *pv SEGDES MMODEL 253 : GOTO 3000 254 : ENDIF 255 : 2 CONTINUE 256 : *pv SEGDES IMODEL 257 : 11 CONTINUE 258 : *pv SEGDES MMODEL 259 : * 260 : * TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT 261 : * 262 : * write (6,*) ' quesup iflag isup nsous ',iflag,isup,nsous 263 : IF (IFLAG.EQ.0) GOTO 1000 264 : IF (IFLAG.EQ.NSOUS) THEN 265 : IF(ISUP.EQ.0) THEN 266 : IRET=ISUP1 267 : ENDIF 268 : GOTO 666 269 : ELSE 270 : GOTO 2000 271 : ENDIF 272 : ENDIF 273 : * 274 : 1000 CONTINUE 275 : * 276 : * IPCHE1 EST AUX NOEUDS 277 : * 278 : IRET=1 279 : IF (ISUP.EQ.1) IRET=0 280 : IF (ICOND.EQ.1.AND.IRET.EQ.1.AND.ISUP.NE.0) GOTO 2000 281 : GOTO 666 282 : * 283 : 2000 CONTINUE 284 : * 285 : IF(ISUP.NE.0)THEN 286 : * 287 : * IPCHE1 EST SUR UN AUTRE SUPPORT QUE CELUI VOULU ET PAS AUX NOEUDS 288 : * 289 : * ==> MESSAGE D'ERREUR POUR QUE L'ON DONNE LE CHAMELEM SUR UN 290 : * SUPPORT CORRECT 291 : * 292 : MOTERR(1:8)=TITCHE 292 : CALL ERREUR(124) 293 : ELSE 294 : * 295 : * LES DIFFERENTS SOUS-ZONES DU CHAMELEM ONT DES POINTS SUPPORTS DIFFERENTS 296 : * 296 : CALL ERREUR(560) 297 : ENDIF 298 : SEGDES MCHELM 299 : IRET=9999 300 : RETURN 301 : * 302 : 3000 CONTINUE 303 : * 304 : * IPCHE1 A UN POINTEUR SUR UN MINTE <> 0 MAIS L'INFCHE(..,6) 305 : * N'EST PAS RENSEIGNE (NE DOIT PAS ARRIVER NORMALEMENT) 306 : * 307 : IRET=9999 307 : CALL ERREUR(53) 308 : * 309 : 666 CONTINUE 310 : *pv SEGDES MCHELM 311 : RETURN 312 : END 313 : 314 : 315 : 316 : 317 : 318 : 319 : 320 : 321 : 322 : 323 : 324 : 325 :
© Cast3M 2003 - All rights reserved.
Disclaimer