1 : C FPTUYA SOURCE CHAT 11/03/16 21:23:12 6902 2 : SUBROUTINE FPTUYA(IPMODL,IPCHE1,IPTFP,IRET) 3 : C____________________________________________________________________ 4 : C 5 : C CALCULE LES FORCES DE PRESSIONS APPLIQUEES SUR DES TUYAUX 6 : C ( EFFET DE FOND ) APPELE PAR PRESSI 7 : C 8 : C 9 : C ENTREES : 10 : C --------- 11 : C 12 : C IPCHE1 POINTEUR SUR UN MCHAML DE CARACTERISTIQUES 13 : C IPMODL POINTEUR SUR UN MMODEL 14 : C 15 : C SORTIES 16 : C 17 : C 18 : C IPTFP CHPOINT DES FORCES NODALES EQUIVALENTES 19 : C IRET 1 OU 0 SI SUCCES OU NON 20 : C 21 : C M. PETIT NOVEMBRE 89 22 : C PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 04 09 90 23 : C 24 : C_____________________________________________________________________ 25 : C 26 : IMPLICIT INTEGER(I-N) 27 : IMPLICIT REAL*8(A-H,O-Z) 28 : C 29 : -INC CCOPTIO 30 : -INC CCREEL 31 : -INC SMCOORD 32 : -INC SMELEME 33 : -INC SMMODEL 34 : -INC SMCHAML 35 : -INC SMINTE 36 : * 37 : SEGMENT NOTYPE 38 : CHARACTER*16 TYPE(NBTYPE) 39 : ENDSEGMENT 40 : C 41 : SEGMENT MPTVAL 42 : INTEGER IPOS(NS) ,NSOF(NS) 43 : INTEGER IVAL(NCOSOU) 44 : CHARACTER*16 TYVAL(NCOSOU) 45 : ENDSEGMENT 46 : C 47 : CHARACTER*8 CMATE 48 : CHARACTER*(NCONCH) CONM 49 : PARAMETER ( NINF=3 ) 50 : INTEGER INFOS(NINF) 51 : LOGICAL lsupfo 52 : C 53 : DIMENSION XFORC(12),WORK(12),VECT(3) 54 : DIMENSION XE(3,2),P(3,3),XX(2),YY(2),ZZ(2) 55 : C 56 : IRET = 0 57 : C 58 : NHRM=NIFOUR 59 : C 60 : C VERIFICATION DU LIEU SUPPORT DU MCHAML DE CARACTERISTIQUE 61 : C 61 : CALL QUESUP (IPMODL,IPCHE1,3,0,ISUP,IRETCA) 62 : IF (ISUP.GT.1) RETURN 63 : C 64 : C ACTIVATION DU MODELE 65 : C 66 : MMODEL=IPMODL 67 : SEGACT MMODEL 68 : NSOUS=KMODEL(/1) 69 : C 70 : C CREATION D UN MCHELM INTERMEDIAIRE 71 : C 72 : N1=NSOUS 73 : L1=5 74 : N3=5 75 : SEGINI MCHELM 76 : ICHAM=MCHELM 77 : TITCHE='FORCE' 78 : IFOCHE=IFOUR 79 : C 80 : C DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES 81 : C 82 : DO 101 ISOUS=1,NSOUS 83 : C 84 : C ON RECUPERE L INFORMATION GENERALE 85 : C 86 : IMODEL=KMODEL(ISOUS) 87 : SEGACT IMODEL 88 : IPMAIL=IMAMOD 89 : CONM =CONMOD 90 : IMACHE(ISOUS)=IPMAIL 91 : CONCHE(ISOUS)=CONMOD 92 : C 93 : C TRAITEMENT DU MODELE 94 : C 95 : MELE=NEFMOD 96 : MELEME=IMAMOD 97 : C 98 : C INFORMATION SUR L'ELEMENT FINI 99 : C 99 : * CALL ELQUOI(MELE,0,3,IPINF,IMODEL) 100 : * IF (IERR.NE.0) THEN 101 : * SEGDES IMODEL,MMODEL 102 : * SEGSUP MCHELM 103 : * RETURN 104 : * ENDIF 105 : * INFO=IPINF 106 : MFR =INFELE(13) 107 : IF (MFR.EQ.13) GOTO 102 108 : C 109 : SEGDES IMODEL,MMODEL 110 : * SEGSUP INFO 111 : SEGSUP MCHELM 111 : CALL ERREUR(16) 112 : RETURN 113 : C 114 : C ON A BIEN DES ELEMENTS TUYA 115 : C 116 : * 102 MINTE=INFELE(11) 117 : 102 MINTE=INFMOD(5) 118 : IPMINT=MINTE 119 : * SEGSUP INFO 120 : C 121 : C CREATION DU TABLEAU INFOS 122 : C 122 : CALL IDENT(IPMAIL,CONM,IPCHE1,0,INFOS,IRTD) 123 : IF (IRTD.EQ.0) THEN 124 : SEGDES IMODEL,MMODEL 125 : SEGSUP MCHELM 126 : RETURN 127 : ENDIF 128 : C 129 : INFCHE(ISOUS,1)=0 130 : INFCHE(ISOUS,2)=0 131 : INFCHE(ISOUS,3)=NHRM 132 : INFCHE(ISOUS,4)=MINTE 133 : INFCHE(ISOUS,5)=0 134 : C 135 : C ACTIVATION DU MELEME 136 : C 137 : SEGACT MELEME 138 : NBNN =NUM(/1) 139 : NBELEM=NUM(/2) 140 : IPPORE=0 141 : IF(MFR.EQ.33) IPPORE=NBNN 142 : C 143 : C RECHERCHE DES NOMS DE COMPOSANTES 144 : C 145 : if(lnomid(2).ne.0) then 146 : nomid=lnomid(2) 147 : segact nomid 148 : moforc=nomid 149 : nfor=lesobl(/2) 150 : nfac=0 151 : lsupfo=.false. 152 : else 153 : lsupfo=.true. 153 : CALL IDFORC(MFR,IFOUR,MOFORC,NFOR,NFAC) 154 : endif 155 : C 156 : C TAILLE DES MELVAL A ALLOUER 157 : C 158 : N1PTEL=2 159 : N1EL=NBELEM 160 : N2PTEL=0 161 : N2EL=0 162 : C 163 : C CREATION DU MCHAML DE LA SOUS ZONE 164 : C 165 : N2=NFOR 166 : SEGINI MCHAML 167 : ICHAML(ISOUS)=MCHAML 168 : NS=1 169 : NCOSOU=NFOR 170 : SEGINI MPTVAL 171 : IVAFOR=MPTVAL 172 : NOMID=MOFORC 173 : SEGACT NOMID 174 : DO 1 ICOMP=1,NFOR 175 : NOMCHE(ICOMP)=LESOBL(ICOMP) 176 : TYPCHE(ICOMP)='REAL*8' 177 : SEGINI MELVAL 178 : IELVAL(ICOMP)=MELVAL 179 : IVAL(ICOMP)=MELVAL 180 : 1 CONTINUE 181 : SEGDES NOMID 182 : C 183 : C TRAITEMENT DES CHAMPS DE CARACTERISTIQUES 184 : C 185 : NBROBL=0 186 : NBRFAC=0 187 : MOCARA=0 188 : NCARA=0 189 : NCARF=0 190 : NCARR=0 191 : C 192 : C CARACTERISTIQUES POUR LES TUYAUX 193 : C 194 : NBROBL=3 195 : NBRFAC=2 196 : SEGINI NOMID 197 : MOCARA=NOMID 198 : LESOBL(1)='EPAI' 199 : LESOBL(2)='RAYO' 200 : LESOBL(3)='PRES' 201 : LESFAC(1)='RACO' 202 : LESFAC(2)='VECT' 203 : * 204 : NBTYPE=5 205 : SEGINI NOTYPE 206 : MOTYPE=NOTYPE 207 : TYPE(1)='REAL*8' 208 : TYPE(2)='REAL*8' 209 : TYPE(3)='REAL*8' 210 : TYPE(4)='REAL*8' 211 : TYPE(5)='POINTEURPOINT ' 212 : C 212 : CALL KOMCHA(IPCHE1,IPMAIL,CONM,MOCARA,MOTYPE,1,INFOS,3,IVACAR) 213 : SEGSUP NOTYPE 214 : IF (IERR.NE.0) GOTO 9990 215 : MPTVAL=IVACAR 216 : NCARA=NBROBL 217 : NCARF=NBRFAC 218 : NCARR=NCARA+NCARF 219 : C 220 : IF (ISUP.EQ.1) THEN 221 : MINTE=IPMINT 222 : SEGACT,MINTE 222 : CALL VALCHE(IVACAR,NCARR,IPMINT,IPPORE) 223 : SEGDES,MINTE 224 : IF(IERR.NE.0)THEN 225 : ISUP=0 226 : GOTO 9990 227 : ENDIF 228 : ENDIF 229 : SEGDES NOMID 230 : C 231 : DO 103 IB=1,NBELEM 232 : C 232 : CALL DOXE(XCOOR,3,2,NUM,IB,XE) 233 : DO 105 J=1,2 234 : XX(J)=XE(1,J) 235 : YY(J)=XE(2,J) 236 : ZZ(J)=XE(3,J) 237 : 105 CONTINUE 238 : C 239 : XLON2=(XX(2)-XX(1))**2+(YY(2)-YY(1))**2+(ZZ(2)-ZZ(1))**2 240 : XLON=SQRT(XLON2) 241 : IF (XLON.NE.0.D0) GOTO 106 242 : C 243 : INTERR(1)=ISOUS 244 : INTERR(2)=IB 244 : CALL ERREUR(128) 245 : GOTO 9990 246 : C 247 : 106 CONTINUE 248 : C 249 : C ON CHERCHE LES CARACTERISTIQUE 250 : C 250 : CALL ZERO(XFORC,1,12) 251 : MPTVAL=IVACAR 252 : C 253 : MELVAL=IVAL(1) 254 : IBMN=MIN(IB,VELCHE(/2)) 255 : EPAI=VELCHE(1,IBMN) 256 : C 257 : MELVAL=IVAL(2) 258 : REXT=VELCHE(1,IBMN) 259 : C 260 : IF (IVAL(4).NE.0) THEN 261 : MELVAL=IVAL(4) 262 : RACO=VELCHE(1,IBMN) 263 : ELSE 264 : RACO=0. 265 : ENDIF 266 : C 267 : MELVAL=IVAL(3) 268 : PRES=VELCHE(1,IBMN) 269 : C 270 : IF (IVAL(NCARR).NE.0) THEN 271 : MELVAL=IVAL(NCARR) 272 : IBMN=MIN(IB,IELCHE(/2)) 273 : IP=IELCHE(1,IBMN) 274 : IREF=(IP-1)*(IDIM+1) 275 : DO 6129 IC=1,3 276 : VECT(IC)=XCOOR(IREF+IC) 277 : 6129 CONTINUE 278 : ELSE 279 : DO 6229 IC=1,3 280 : VECT(IC)=0. 281 : 6229 CONTINUE 282 : ENDIF 283 : C 284 : C 285 : RINT=REXT-EPAI 286 : FL=XPI*PRES*RINT**2 287 : IF (RACO.NE.0.D0) THEN 288 : FL=FL/SQRT(1.D0-0.25D0*XLON2/RACO**2) 289 : ENDIF 289 : CALL ZERO(WORK,1,12) 290 : WORK(1)=-FL 291 : WORK(7)=FL 292 : C 292 : CALL POUPAS(XX,YY,ZZ,VECT,P,KERRE) 293 : IF (KERRE.EQ.0) GOTO 107 294 : C 295 : INTERR(1)=ISOUS 296 : INTERR(2)=IB 296 : CALL ERREUR(138) 297 : GOTO 9990 298 : C 299 : 107 CONTINUE 299 : CALL POUVEC(WORK,XFORC,P,2) 300 : IE=0 301 : C 302 : C REMPLISSAGE DU SEGMENT CONTENANT LES FORCES 303 : C 304 : MPTVAL=IVAFOR 305 : DO 104 IGAU=1,2 306 : DO 104 ICOMP=1,6 307 : MELVAL=IVAL(ICOMP) 308 : IGMN=MIN(IGAU,VELCHE(/1)) 309 : IBMN=MIN(IB ,VELCHE(/2)) 310 : IE=IE+1 311 : VELCHE(IGMN,IBMN)=XFORC(IE) 312 : 104 CONTINUE 313 : C 314 : 103 CONTINUE 315 : C 316 : 510 SEGDES MELEME 317 : SEGDES IMODEL 318 : C 319 : NOMID=MOCARA 320 : IF (MOCARA.NE.0) SEGSUP NOMID 321 : IF (ISUP.EQ.1) THEN 321 : CALL DTMVAL(IVACAR,3) 322 : ELSE 322 : CALL DTMVAL(IVACAR,1) 323 : ENDIF 324 : C 325 : NOMID=MOFORC 326 : if(lsupfo)SEGSUP NOMID 326 : CALL DTMVAL(IVAFOR,1) 327 : C 328 : SEGDES MCHAML 329 : C 330 : 101 CONTINUE 331 : SEGDES MMODEL 332 : SEGDES MCHELM 333 : IRET = 1 333 : CALL CHAMPO(ICHAM,0,IPTFP,IRET) 333 : CALL DTCHAM(ICHAM) 334 : RETURN 335 : C 336 : 9990 CONTINUE 337 : IRET=0 338 : C 339 : C ERREUR DANS UNE SOUS ZONE, DESACTIVATION ET RETOUR 340 : C 341 : NOMID=MOCARA 342 : IF (MOCARA.NE.0) SEGSUP NOMID 343 : IF (ISUP.EQ.1) THEN 343 : CALL DTMVAL(IVACAR,3) 344 : ELSE 344 : CALL DTMVAL(IVACAR,1) 345 : ENDIF 346 : C 347 : NOMID=MOFORC 348 : if(lsupfo)SEGSUP NOMID 348 : CALL DTMVAL(IVAFOR,1) 349 : C 350 : SEGDES MELEME 351 : SEGDES IMODEL 352 : SEGDES MMODEL 353 : SEGSUP MCHELM 354 : C 355 : RETURN 356 : END 357 : 358 : 359 :
© Cast3M 2003 - All rights reserved.
Disclaimer