1 : C CHACO1 SOURCE PV 09/03/12 21:16:40 6325 2 : SUBROUTINE CHACO1(IPSONO,IPSON1,IPSON2,IEP,IPGEOM,IPINTE,IPCHEQ, 3 : . IPCHE1,IPCHE2) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8(A-H,O-Z) 6 : ************************************************************************ 7 : * 8 : * C H A C O 1 9 : * ----------- 10 : * 11 : * FONCTION: 12 : * --------- 13 : * CAS DES SOURCES VOLUMIQUES 14 : * COQUES SEGMENT AXISYMETRIQUE ET TRIANGLE 15 : * 16 : * MODULES UTILISES: 17 : * ----------------- 18 : * 19 : -INC CCOPTIO 20 : -INC CCREEL 21 : -INC SMCHAML 22 : -INC SMELEME 23 : -INC SMINTE 24 : -INC SMCOORD 25 : * 26 : * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN) 27 : * ----------- 28 : * 29 : * IPSONO (E) POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES 30 : * IPSON1 SOURCES 31 : * IPSON2 32 : * IEP (E) POINTEUR SUR UN SEGMENT MELVAL COTENANT LES EPAISSEUR 33 : * IPGEOM (E) POINTEUR SUR UN OBJET MAILLAGE ELEMENTAIRE 34 : * IPINTE (E) POINTEUR SUR UN SEGMENT MINTE CONTENANT LES 35 : * CARACTERISTIQUES D'INTEGRATION 36 : * +IDIM (E) VOIR CCOPTIO 37 : * +XPI (E) VOIR CCREEL 38 : * IPCHEQ (S) POINTEURS SUR DES SEGMENTS MELVAL CONTENANT LES 39 : * IPCHE1 CHALEURS NODALES EQUIVALENTES 40 : * IPCHE2 41 : * 42 : * VARIABLES: 43 : * ---------- 44 : * 45 : * XE(3,NBPTEL) = COORDONNEES DES ELEMENTS DANS LE REPERE GLOBAL 46 : * SURF = SURFACE ELEMENTAIRE AU POINT DE GAUSS 47 : * A ET S = TABLEAUX DE TRAVAIL 48 : * 49 : REAL*8 S(6) 50 : SEGMENT,MMAT1 51 : REAL*8 XE(3,NBPTEL),A(NBPTEL,NBPTEL),SHP(6,NBPTEL),AA(NBE,NBE) 52 : ENDSEGMENT 53 : * 54 : * CONSTANTES: 55 : * ----------- 56 : * 57 : PARAMETER ( O1=1.D0 ) 58 : PARAMETER ( O2=2.D0,O30=30.D0,O8=8.D0,O15=15.D0) 59 : * 60 : * AUTEUR, DATE DE CREATION: 61 : * ------------------------- 62 : * 63 : * P. DOWLATYARI JUIN 90 ADAPTATION DE CHAMAS 64 : * 65 : * LANGAGE: 66 : * -------- 67 : * 68 : * ESOPE + FORTRAN77 69 : * 70 : ************************************************************************ 71 : * 72 : * ON RECUPERE LES VALEURS DES SOURCES 73 : * 74 : MELVA1=IPSONO 75 : SEGACT,MELVA1 76 : NBPTE1=MELVA1.VELCHE(/1) 77 : NEL1=MELVA1.VELCHE(/2) 78 : MELVA2=IPSON1 79 : SEGACT,MELVA2 80 : MELVA3=IPSON2 81 : SEGACT,MELVA3 82 : * 83 : * ON RECUPERE LES CARACTERISTIQUES D'INTEGRATION 84 : * 85 : MINTE=IPINTE 86 : SEGACT,MINTE 87 : NBPGAU=POIGAU(/1) 88 : NBNO=SHPTOT(/2) 89 : * 90 : * ON RECUPERE UN DES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE 91 : * 92 : MELEME=IPGEOM 93 : SEGACT,MELEME 94 : NBPTEL=NUM(/1) 95 : NEL=NUM(/2) 96 : * 97 : * INITIALISATION DES MELVALS QUI CONTIENDRA LES CHALEURS EQUIVALENTE 98 : * 99 : N1PTEL=NBPTEL 100 : N1EL=NEL 101 : N2PTEL=0 102 : N2EL=0 103 : NBE=3*NBPTEL 104 : SEGINI,MELVAL 105 : IPCHEQ=MELVAL 106 : SEGINI,MELVA4 107 : IPCHE1=MELVA4 108 : SEGINI,MELVA5 109 : IPCHE2=MELVA5 110 : SEGINI,MMAT1 111 : MELVA6=IEP 112 : SEGACT,MELVA6 113 : * 114 : * BOUCLE SUR LES ELEMENTS 115 : * 116 : DO 10 IEL=1,NEL 117 : * 118 : * ON CHERCHE LES COORDONNEES DES NOEUDS DANS LE REPERE GLOBAL 119 : * 119 : CALL DOXE(XCOOR,IDIM,NBPTEL,NUM,IEL,XE) 120 : * 121 : * BOUCLE SUR LES POINTS DE GAUSS 122 : * 122 : CALL ZERO(A,NBPTEL,NBPTEL) 123 : DO 40 IGAU=1,NBPGAU 124 : AXIS=O1 125 : IF (NBNO.EQ.2) THEN 126 : * 127 : * CALCUL DE LA LONGUEUR ( POUR L'ELEMENT BARRE ) 128 : * 129 : DLX=XZERO 130 : DLY=XZERO 131 : DO 400 INOE=1,NBPTEL 132 : DLX=DLX+SHPTOT(2,INOE,IGAU)*XE(1,INOE) 133 : DLY=DLY+SHPTOT(2,INOE,IGAU)*XE(2,INOE) 134 : 400 CONTINUE 135 : * END DO 136 : SURF=SQRT(DLX**2+DLY**2) 137 : ELSE 138 : * 139 : * CALCUL DE LA SURFACE ELEMENTAIRE AU POINT DE GAUSS CONSIDERE 140 : * 141 : SURFX=XZERO 142 : SURFY=XZERO 143 : SURFZ=XZERO 144 : DO 21 I=1,6 145 : S(I)=XZERO 146 : 21 CONTINUE 147 : * END DO 148 : DO 30 INOE=1,NBPTEL 149 : S(1)=S(1)+SHPTOT(2,INOE,IGAU)*XE(2,INOE) 150 : S(2)=S(2)+SHPTOT(3,INOE,IGAU)*XE(3,INOE) 151 : S(3)=S(3)+SHPTOT(3,INOE,IGAU)*XE(2,INOE) 152 : S(4)=S(4)+SHPTOT(2,INOE,IGAU)*XE(3,INOE) 153 : S(5)=S(5)+SHPTOT(3,INOE,IGAU)*XE(1,INOE) 154 : S(6)=S(6)+SHPTOT(2,INOE,IGAU)*XE(1,INOE) 155 : 30 CONTINUE 156 : * END DO 157 : SURFX=S(1)*S(2)-S(3)*S(4) 158 : SURFY=S(4)*S(5)-S(2)*S(6) 159 : SURFZ=S(6)*S(3)-S(5)*S(1) 160 : SURF=SQRT(SURFX**2+SURFY**2+SURFZ**2) 161 : ENDIF 162 : IF (IFOMOD.EQ.0) THEN 163 : * 164 : * CAS DES ELEMENTS AXISYMETRIQUES 165 : * 166 : DO 41 NP=1,NBPTEL 167 : SHP(1,NP)=SHPTOT(1,NP,IGAU) 168 : SHP(2,NP)=SHPTOT(2,NP,IGAU) 169 : SHP(3,NP)=SHPTOT(3,NP,IGAU) 170 : 41 CONTINUE 171 : * END DO 171 : CALL DISTRR(XE,SHP,NBPTEL,RR) 172 : AXIS=XPI*RR*O2 173 : ENDIF 174 : DO 50 INO1=1,NBPTEL 175 : DO 60 INO2=1,NBPTEL 176 : A(INO1,INO2)=A(INO1,INO2)+SHPTOT(1,INO1,IGAU)* 177 : 1 SHPTOT(1,INO2,IGAU)*POIGAU(IGAU)*AXIS*SURF 178 : 60 CONTINUE 179 : * END DO 180 : 50 CONTINUE 181 : * END DO 182 : 40 CONTINUE 183 : * END DO 184 : * 185 : * RECUPERATION DE L'EPAISSEUR 186 : * 187 : EP=0.D0 188 : IEMN=MIN(IEL,MELVA6.VELCHE(/2)) 189 : DO 45 INO=1,NBNO 190 : INMN=MIN(INO,MELVA6.VELCHE(/1)) 191 : EP=MELVA6.VELCHE(INMN,IEMN)+EP 192 : 45 CONTINUE 193 : EP=EP/NBNO 194 : * 195 : * INTEGRATION ANALYTIQUE SUR EPAISSEUR 196 : * 197 : C1=(O2*EP)/O15 198 : C2=EP/O15 199 : C3=-EP/O30 200 : C4=(O8*EP)/O15 201 : C5=EP/O15 202 : C6=(O2*EP)/O15 203 : * 204 : DO 80 J=1,NBPTEL 205 : DO 80 I=1,NBPTEL 206 : AA(I,J)=C1*A(I,J) 207 : 80 CONTINUE 208 : * 209 : * 210 : DO 90 J=1,NBPTEL 211 : DO 90 I=1,NBPTEL 212 : II=I+NBPTEL 213 : AA(II,J)=C2*A(I,J) 214 : AA(J,II)=AA(II,J) 215 : 90 CONTINUE 216 : * 217 : DO 100 J=1,NBPTEL 218 : DO 100 I=1,NBPTEL 219 : II=I+2*NBPTEL 220 : AA(II,J)=C3*A(I,J) 221 : AA(J,II)=AA(II,J) 222 : 100 CONTINUE 223 : * 224 : DO 110 J=1,NBPTEL 225 : JJ=J+NBPTEL 226 : DO 110 I=1,NBPTEL 227 : II=I+NBPTEL 228 : AA(II,JJ)=C4*A(I,J) 229 : 110 CONTINUE 230 : * 231 : DO 120 J=1,NBPTEL 232 : JJ=J+NBPTEL 233 : DO 120 I=1,NBPTEL 234 : II=I+2*NBPTEL 235 : AA(II,JJ)=C5*A(I,J) 236 : AA(JJ,II)=AA(II,JJ) 237 : 120 CONTINUE 238 : * 239 : DO 130 J=1,NBPTEL 240 : JJ=J+2*NBPTEL 241 : DO 130 I=1,NBPTEL 242 : II=I+2*NBPTEL 243 : AA(II,JJ)=C6*A(I,J) 244 : 130 CONTINUE 245 : * 246 : * (INTEGRAL DE HTH)*VALEURS NODALES DES SOURCES 247 : * 248 : IEMIN=MIN(NEL1,IEL) 249 : DO 70 INO3=1,NBE 250 : DO 70 INO4=1,NBE 251 : IF(INO3.LE.NBPTEL)THEN 252 : IF(INO4.LE.NBPTEL)THEN 253 : INMIN=MIN(NBPTE1,INO4) 254 : VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA1.VELCHE(INMIN,IEMIN)* 255 : 1 AA(INO4,INO3) 256 : ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN 257 : INO5=INO4-NBPTEL 258 : INMIN=MIN(NBPTE1,INO5) 259 : VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA2.VELCHE(INMIN,IEMIN)* 260 : 1 AA(INO4,INO3) 261 : ELSE 262 : INO5=INO4-2*NBPTEL 263 : INMIN=MIN(NBPTE1,INO5) 264 : VELCHE(INO3,IEL)=VELCHE(INO3,IEL)+MELVA3.VELCHE(INMIN,IEMIN)* 265 : 1 AA(INO4,INO3) 266 : ENDIF 267 : ELSEIF(INO3.GT.NBPTEL.AND.INO3.LE.(2*NBPTEL))THEN 268 : INO6=INO3 - NBPTEL 269 : IF(INO4.LE.NBPTEL)THEN 270 : INMIN=MIN(NBPTE1,INO4) 271 : MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+ 272 : 1 MELVA1.VELCHE(INMIN,IEMIN)*AA(INO4,INO3) 273 : ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN 274 : INO5=INO4-NBPTEL 275 : INMIN=MIN(NBPTE1,INO5) 276 : MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+ 277 : 1 MELVA2.VELCHE(INMIN,IEMIN)*AA(INO4,INO3) 278 : ELSE 279 : INO5=INO4-2*NBPTEL 280 : INMIN=MIN(NBPTE1,INO5) 281 : MELVA4.VELCHE(INO6,IEL)=MELVA4.VELCHE(INO6,IEL)+ 282 : 1 MELVA3.VELCHE(INMIN,IEMIN)*AA(INO4,INO3) 283 : ENDIF 284 : ELSE 285 : INO6=INO3 -2*NBPTEL 286 : IF(INO4.LE.NBPTEL)THEN 287 : INMIN=MIN(NBPTE1,INO4) 288 : MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+ 289 : 1 MELVA1.VELCHE(INMIN,IEMIN)*AA(INO4,INO3) 290 : ELSEIF(INO4.GT.NBPTEL.AND.INO4.LE.(2*NBPTEL))THEN 291 : INO5=INO4-NBPTEL 292 : INMIN=MIN(NBPTE1,INO5) 293 : MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+ 294 : 1 MELVA2.VELCHE(INMIN,IEMIN)*AA(INO4,INO3) 295 : ELSE 296 : INO5=INO4-2*NBPTEL 297 : INMIN=MIN(NBPTE1,INO5) 298 : MELVA5.VELCHE(INO6,IEL)=MELVA5.VELCHE(INO6,IEL)+ 299 : 1 MELVA3.VELCHE(INMIN,IEMIN)*AA(INO4,INO3) 300 : ENDIF 301 : ENDIF 302 : 70 CONTINUE 303 : * END DO 304 : 10 CONTINUE 305 : * END DO 306 : * 307 : SEGSUP,MMAT1 308 : SEGDES,MELEME,MELVA1,MINTE,MELVA2 ,MELVA6 309 : SEGDES,MELVA3,MELVAL,MELVA4,MELVA5 310 : * 311 : END 312 : 313 : 314 : 315 : 316 : 317 :
© Cast3M 2003 - All rights reserved.
Disclaimer