1 : C TOWA SOURCE CHAT 09/10/09 21:25:35 6519 2 : SUBROUTINE TOWA (IPTAB1) 3 : C 4 : C*********************************************************************** 5 : C 6 : C 7 : C FONCTION: 8 : C --------- 9 : C 10 : C en "1D/0D" sur des éléments de type POINT. 11 : C 12 : C 13 : C ENTREE : 14 : C ---------- 15 : C 16 : C IPTAB1 : Pointeur sur la TABLE de soustype 'OPER_0D' 17 : C contenant les indices suivants : 18 : C 19 : C TAB1 . 'GEOINF' : TABLE des informations géométriques de soustype 20 : C 'GEOINF' (type ENTIER). 21 : C TAB1 . 'INCO' : TABLE de soustype 'INCO' contenant l'ensemble 22 : C des champs à l'itération précédant l'itération 23 : C courante (type ENTIER). 24 : C TAB1 . 'DUAL' : Nom de l'inconnue duale (doit être un indice de 25 : C la table de soustype 'INCO' et de support 26 : C 'WALL') (type MOT). 27 : C TAB1 . 'PRIMAL' : Nom de l'inconnue duale (doit être un indice de 28 : C la table de soustype 'INCO' et de support 29 : C 'WALL') (type MOT). 30 : C TAB1 . 'DT' : Pas de temps (type FLOTTANT ou MOT). 31 : C TAB1 . 'CP' : Chaleurs spécifiques des murs 32 : C (type CHPO, de support 'WALL', à 2 composantes) 33 : C TAB1 . 'RHO' : Masses volumiques des murs 34 : C (type CHPO, de support 'WALL', à 2 composantes) 35 : C TAB1 . 'LBD' : Conductivités thermiques spécifiques des murs 36 : C (type CHPO, de support 'WALL', à 2 composantes) 37 : C TAB1 . 'THICK' : Epaisseurs des murs 38 : C (type CHPO, de support 'WALL', à 2 composantes) 39 : C 40 : C RESULTATS: 41 : C --------- 42 : C 43 : C TAB1 . 'LHS' : Matrice élémentaire (union des matrices 44 : C élémentaires associées à l'opération 45 : C type RIGIDITE). 46 : C TAB1 . 'RHS' : Second membre associé à l'opération 47 : C (type CHPO partitionné). 48 : C 49 : C 50 : C AUTEUR, DATE DE CREATION: 51 : C ------------------------- 52 : C 53 : C Laurent DADA décembre 1996 54 : C 55 : C 56 : C LANGAGE: 57 : C -------- 58 : C 59 : C ESOPE + FORTRAN77 60 : C 61 : C*********************************************************************** 62 : C 63 : IMPLICIT INTEGER(I-N) 64 : IMPLICIT REAL*8 (A-H,O-Z) 65 : C 66 : -INC CCOPTIO 67 : -INC CCGEOME 68 : -INC SMCOORD 69 : -INC SMTABLE 70 : POINTEUR IPTAB1.MTABLE,IPTAB2.MTABLE,IPTABG.MTABLE 71 : POINTEUR IPTABS.MTABLE,IPTABI.MTABLE 72 : -INC SMCHPOI 73 : POINTEUR MPOVC1.MPOVAL,MPOVR1.MPOVAL,MPOVD1.MPOVAL 74 : POINTEUR MPOVL1.MPOVAL,MPOVT1.MPOVAL,MPOVQ1.MPOVAL 75 : -INC SMELEME 76 : POINTEUR IPCEN.MELEME,IPINW.MELEME 77 : -INC SMRIGID 78 : -INC SMLMOTS 79 : C 80 : C Tableaux des correspondances entre les numéros des points et 81 : C leurs positions dans les MELEME des champs 82 : C 83 : SEGMENT REDIR 84 : INTEGER IPOSC1(NNGOT) 85 : INTEGER IPOSR1(NNGOT) 86 : INTEGER IPOSL1(NNGOT) 87 : INTEGER IPOST1(NNGOT) 88 : INTEGER IPOSQ1(NNGOT) 89 : INTEGER IPOSD1(NNGOT) 90 : ENDSEGMENT 91 : C 92 : C Tableaux des positions des noms de composantes "gauches et droites" 93 : C pour les champs de propriétés matérielles 94 : C 95 : SEGMENT NOCOPO 96 : INTEGER NOCOC1(2) 97 : INTEGER NOCOR1(2) 98 : INTEGER NOCOL1(2) 99 : INTEGER NOCOT1(2) 100 : ENDSEGMENT 101 : C 102 : C 103 : CHARACTER*8 TYPE,MOTI,MOT1,NOMPR1,NOMDU1,NOSUD1,NOMDT1 104 : CHARACTER*8 NOMP1,NOMP2,NOMPR2,NOSUP2,NOMFL1,NOSUF1 105 : CHARACTER*8 MTYPI,MTYPR,CHARI,CHARR 106 : LOGICAL LOGII,LOGIR 107 : C 108 : C 109 : C Lecture de la table GEOINF de la table OPER_0D 110 : C 111 : TYPE = 'TABLE ' 111 : CALL ACMO (IPTAB1,'GEOINF',TYPE,IPTABG) 112 : IF (IERR.NE.0) RETURN 113 : C 114 : MOTI = 'SOUSTYPE' 114 : CALL ACMM (IPTABG,MOTI,MOT1) 115 : IF (IERR.NE.0) RETURN 116 : IF (MOT1(1:6).NE.'GEOINF') THEN 117 : MOTERR(1:8) = 'GEOINF ' 117 : CALL ERREUR (-173) 118 : RETURN 119 : ENDIF 120 : C 121 : C Lecture de la table INCO dans la table OPER_0D 122 : C 123 : TYPE = 'TABLE ' 123 : CALL ACMO (IPTAB1,'INCO',TYPE,IPTAB2) 124 : IF (IERR.NE.0) RETURN 125 : C 126 : MOTI = 'SOUSTYPE' 126 : CALL ACMM (IPTAB2,MOTI,MOT1) 127 : IF (IERR.NE.0) RETURN 128 : IF (MOT1(1:4).NE.'INCO') THEN 129 : MOTERR(1:8) = 'INCO ' 129 : CALL ERREUR (-173) 130 : RETURN 131 : ENDIF 132 : C 133 : C Lecture de la table SUPPORT dans la table INCO 134 : C 135 : C TYPE = 'TABLE ' 135 : C CALL ACMO (IPTAB2,'SUPPORT',TYPE,IPTABS) 136 : C IF (IERR.NE.0) RETURN 137 : C 138 : C Lecture de l'inconnue DUALE 139 : C 140 : TYPE = ' ' 140 : CALL ACMO (IPTAB1,'DUAL',TYPE,IDU1) 141 : IF (TYPE.EQ.'MOT ') THEN 141 : CALL ACMM (IPTAB1,'DUAL',NOMDU1) 142 : IF (IERR.NE.0) RETURN 143 : ENDIF 144 : C 145 : C Lecture du nom du support de l'inconnue duale 146 : C 147 : C TYPE = ' ' 147 : C CALL ACMO (IPTABS,NOMDU1,TYPE,ISUD1) 148 : C IF (TYPE.EQ.'MOT ') THEN 148 : C CALL ACMM (IPTABS,NOMDU1,NOSUD1) 149 : C IF (IERR.NE.0) RETURN 150 : C ENDIF 151 : C 152 : C Contrôle du support de l'inconnue duale 153 : C 154 : C IF (NOSUD1.NE.'WALL') THEN 155 : C MOTERR(1:8) = 'DUAL ' 156 : C MOTERR(9:16) = 'CHPOINT ' 156 : C CALL ERREUR (788) 157 : C RETURN 158 : C ENDIF 159 : C 160 : C Lecture de l'inconnue primale 161 : C 162 : TYPE = ' ' 162 : CALL ACMO (IPTAB1,'PRIMAL',TYPE,IPR1) 163 : IF (TYPE.EQ.'MOT ') THEN 163 : CALL ACMM (IPTAB1,'PRIMAL',NOMPR1) 164 : IF (IERR.NE.0) RETURN 165 : IF (NOMPR1.NE.NOMDU1) THEN 166 : MOTERR(1:8) = 'PRIMAL ' 167 : MOTERR(9:16) = NOMPR1 167 : CALL ERREUR (787) 168 : RETURN 169 : ENDIF 170 : ENDIF 171 : C 172 : C Lecture du pas de temps 173 : C 174 : TYPE = ' ' 174 : CALL ACMO (IPTAB1,'DT',TYPE,IPR1) 175 : IF (IERR.NE.0) RETURN 176 : IF (TYPE.EQ.'MOT ') THEN 176 : CALL ACMM (IPTAB1,'DT',NOMDT1) 177 : IF (IERR.NE.0) RETURN 178 : C récupération du pas de temps dans la table INCO 178 : CALL ACMF (IPTAB2,NOMDT1,XDT1) 179 : IF (IERR.NE.0) RETURN 180 : ELSEIF (TYPE.EQ.'FLOTTANT') THEN 180 : CALL ACMF (IPTAB1,'DT',XDT1) 181 : IF (IERR.NE.0) RETURN 182 : ELSE 183 : MOTERR(1:8) = 'DT ' 184 : MOTERR(9:16) = TYPE 184 : CALL ERREUR (787) 185 : RETURN 186 : ENDIF 187 : C 188 : C 189 : C Récupération des propriétés matérielles des murs 190 : C Récupération des segments MPOVAL des champs 191 : C Initialisation des tableaux des correspondances 192 : C Initialisation des tableaux des positions des noms des composantes 193 : C 194 : NNGOT = XCOOR(/1)/(IDIM+1) 195 : SEGINI REDIR 196 : SEGINI NOCOPO 197 : C 198 : C Les chaleurs spécifiques 199 : C 200 : TYPE = 'CHPOINT ' 200 : CALL ACMO (IPTAB1,'CP',TYPE,MCHPO1) 201 : IF (IERR.NE.0) RETURN 202 : SEGACT MCHPO1 203 : MSOUPO = MCHPO1.IPCHP(1) 204 : SEGDES MCHPO1 205 : SEGACT MSOUPO 206 : NC1 = NOCOMP(/2) 207 : IF (NC1.NE.2) THEN 208 : MOTERR(1:8) = 'CP ' 209 : MOTERR(9:16) = 'CHPOINT ' 209 : CALL ERREUR (784) 210 : RETURN 211 : ENDIF 212 : IF ((NOCOMP(1).EQ.'1CW').AND.(NOCOMP(2).EQ.'2CW')) THEN 213 : NOCOC1(1) = 1 214 : NOCOC1(2) = 2 215 : ELSEIF ((NOCOMP(2).EQ.'1CW').AND.(NOCOMP(1).EQ.'2CW')) THEN 216 : NOCOC1(1) = 2 217 : NOCOC1(2) = 1 218 : ELSE 219 : MOTERR(1:8) = 'CP ' 220 : MOTERR(9:16) = 'composan' 220 : CALL ERREUR (787) 221 : RETURN 222 : ENDIF 223 : MPOVC1 = IPOVAL 224 : IPT1 = IGEOC 225 : SEGDES MSOUPO 226 : C 227 : SEGACT IPT1 228 : NBEL1 = IPT1.NUM(/2) 229 : DO 100 I100=1,NBEL1 230 : IPOSC1(IPT1.NUM(1,I100)) = I100 231 : 100 CONTINUE 232 : SEGDES IPT1 233 : C 234 : C Les masses volumiques 235 : C 236 : TYPE = 'CHPOINT ' 236 : CALL ACMO (IPTAB1,'RHO',TYPE,MCHPO1) 237 : IF (IERR.NE.0) RETURN 238 : SEGACT MCHPO1 239 : MSOUPO = MCHPO1.IPCHP(1) 240 : SEGDES MCHPO1 241 : SEGACT MSOUPO 242 : NC1 = NOCOMP(/2) 243 : IF (NC1.NE.2) THEN 244 : MOTERR(1:8) = 'RHO ' 245 : MOTERR(9:16) = 'CHPOINT ' 245 : CALL ERREUR (784) 246 : RETURN 247 : ENDIF 248 : IF ((NOCOMP(1).EQ.'1RW').AND.(NOCOMP(2).EQ.'2RW')) THEN 249 : NOCOR1(1) = 1 250 : NOCOR1(2) = 2 251 : ELSEIF ((NOCOMP(2).EQ.'1RW').AND.(NOCOMP(1).EQ.'2RW')) THEN 252 : NOCOR1(1) = 2 253 : NOCOR1(2) = 1 254 : ELSE 255 : MOTERR(1:8) = 'RHO ' 256 : MOTERR(9:16) = 'composan' 256 : CALL ERREUR (787) 257 : RETURN 258 : ENDIF 259 : MPOVR1 = IPOVAL 260 : IPT1 = IGEOC 261 : SEGDES MSOUPO 262 : C 263 : SEGACT IPT1 264 : NBEL1 = IPT1.NUM(/2) 265 : DO 200 I200=1,NBEL1 266 : IPOSR1(IPT1.NUM(1,I200)) = I200 267 : 200 CONTINUE 268 : SEGDES IPT1 269 : C 270 : C Les conductivités thermiques 271 : C 272 : TYPE = 'CHPOINT ' 272 : CALL ACMO (IPTAB1,'LBD',TYPE,MCHPO1) 273 : IF (IERR.NE.0) RETURN 274 : SEGACT MCHPO1 275 : MSOUPO = MCHPO1.IPCHP(1) 276 : SEGDES MCHPO1 277 : SEGACT MSOUPO 278 : NC1 = NOCOMP(/2) 279 : IF (NC1.NE.2) THEN 280 : MOTERR(1:8) = 'LBD ' 281 : MOTERR(9:16) = 'CHPOINT ' 281 : CALL ERREUR (784) 282 : RETURN 283 : ENDIF 284 : IF ((NOCOMP(1).EQ.'1LW').AND.(NOCOMP(2).EQ.'2LW')) THEN 285 : NOCOL1(1) = 1 286 : NOCOL1(2) = 2 287 : ELSEIF ((NOCOMP(2).EQ.'1LW').AND.(NOCOMP(1).EQ.'2LW')) THEN 288 : NOCOL1(1) = 2 289 : NOCOL1(2) = 1 290 : ELSE 291 : MOTERR(1:8) = 'LBD ' 292 : MOTERR(9:16) = 'composan' 292 : CALL ERREUR (787) 293 : RETURN 294 : ENDIF 295 : MPOVL1 = IPOVAL 296 : IPT1 = IGEOC 297 : SEGDES MSOUPO 298 : C 299 : SEGACT IPT1 300 : NBEL1 = IPT1.NUM(/2) 301 : DO 300 I300=1,NBEL1 302 : IPOSL1(IPT1.NUM(1,I300)) = I300 303 : 300 CONTINUE 304 : SEGDES IPT1 305 : C 306 : C Les épaisseurs 307 : C 308 : TYPE = 'CHPOINT ' 308 : CALL ACMO (IPTAB1,'THICK',TYPE,MCHPO1) 309 : IF (IERR.NE.0) RETURN 310 : SEGACT MCHPO1 311 : MSOUPO = MCHPO1.IPCHP(1) 312 : SEGDES MCHPO1 313 : SEGACT MSOUPO 314 : NC1 = NOCOMP(/2) 315 : IF (NC1.NE.2) THEN 316 : MOTERR(1:8) = 'THICK ' 317 : MOTERR(9:16) = 'CHPOINT ' 317 : CALL ERREUR (784) 318 : RETURN 319 : ENDIF 320 : IF ((NOCOMP(1).EQ.'1TW').AND.(NOCOMP(2).EQ.'2TW')) THEN 321 : NOCOT1(1) = 1 322 : NOCOT1(2) = 2 323 : ELSEIF ((NOCOMP(2).EQ.'1TW').AND.(NOCOMP(1).EQ.'2TW')) THEN 324 : NOCOT1(1) = 2 325 : NOCOT1(2) = 1 326 : ELSE 327 : MOTERR(1:8) = 'THICK ' 328 : MOTERR(9:16) = 'composan' 328 : CALL ERREUR (787) 329 : RETURN 330 : ENDIF 331 : MPOVT1 = IPOVAL 332 : IPT1 = IGEOC 333 : SEGDES MSOUPO 334 : C 335 : SEGACT IPT1 336 : NBEL1 = IPT1.NUM(/2) 337 : DO 400 I400=1,NBEL1 338 : IPOST1(IPT1.NUM(1,I400)) = I400 339 : 400 CONTINUE 340 : SEGDES IPT1 341 : C 342 : C Récupération des valeurs de l'inconnue duale à l'itération 343 : C précédente 344 : C 345 : TYPE = 'CHPOINT ' 345 : CALL ACMO (IPTAB2,NOMDU1,TYPE,IPCHD1) 346 : IF (IERR.NE.0) RETURN 346 : CALL LICHT (IPCHD1,MPOVD1,TYPE,IPT1) 347 : SEGACT IPT1 348 : NBEL1 = IPT1.NUM(/2) 349 : DO 500 I500=1,NBEL1 350 : IPOSD1(IPT1.NUM(1,I500)) = I500 351 : 500 CONTINUE 352 : SEGDES IPT1 353 : SEGDES MPOVD1 354 : C 355 : C Récupération du MAILLAGE de POI1 localisant les centres des murs 356 : C 357 : TYPE = 'MAILLAGE' 357 : CALL ACMO (IPTABG,'CENTRW',TYPE,IPCEN) 358 : IF (IERR.NE.0) RETURN 359 : SEGACT IPCEN 360 : IF ((IPCEN.ITYPEL).NE.1) THEN 361 : MOTERR(1:8) = 'CENTRW ' 362 : MOTERR(9:16) = 'non POI1' 362 : CALL ERREUR (787) 363 : SEGDES IPCEN 364 : RETURN 365 : ENDIF 366 : C 367 : C Récupération de la TABLE des correspondances 368 : C centres des murs -> points des murs 369 : C 370 : TYPE = 'TABLE ' 370 : CALL ACMO (IPTABG,'INWALL',TYPE,IPTABI) 371 : IF (IERR.NE.0) RETURN 372 : C 373 : C Création de la RIGIDITE 374 : C 375 : NBELC1 = IPCEN.NUM(/2) 376 : C 377 : NRIGE = 7 378 : NRIGEL = NBELC1 379 : SEGINI MRIGID 380 : MTYMAT = 'RIGIDITE' 381 : IFORIG = IFOMOD 382 : ICHOLE = 0 383 : IMGEO1 = 0 384 : IMGEO2 = 0 385 : ISUPEQ = 0 386 : C 387 : C 388 : C Création des matrices élémentaires 389 : C et des seconds membres 390 : C 391 : C 392 : SEGDES REDIR 393 : SEGDES NOCOPO 394 : C 395 : MTYPI = 'POINT ' 396 : MTYPR = 'MAILLAGE' 397 : DO 10 I10=1,NBELC1 398 : NUM1 = IPCEN.NUM(1,I10) 399 : C Récupération du MAILLAGE de POI1, support des points du mur 400 : C associé au point centre NUM1 400 : CALL ACCTAB (IPTABI,MTYPI,IVALI,XVARI,CHARI,LOGII,NUM1, 401 : & MTYPR,IVALR,XVALR,CHARR,LOGIR,IRETR) 402 : IF (IERR.NE.0) RETURN 403 : IPINW = IRETR 404 : SEGACT IPINW 405 : IF ((IPINW.ITYPEL).NE.1) THEN 406 : MOTERR(1:8) = 'INWALL ' 407 : MOTERR(9:16) = 'non POI1' 407 : CALL ERREUR (787) 408 : SEGDES IPINW 409 : RETURN 410 : ENDIF 411 : C 412 : C Transformation du maillage de POI1 413 : C en un maillage de type SUPER-ELEMENT pour la RIGIDITE 414 : C 415 : NBNN = IPINW.NUM(/2) 416 : NBSOUS = 0 417 : NBREF = 0 418 : NBELEM = 1 419 : SEGINI MELEME 420 : ICOLOR(1) = IDCOUL 421 : ITYPEL = 28 422 : DO 11 I11=1,NBNN 423 : NUM(I11,1) = IPINW.NUM(1,I11) 424 : 11 CONTINUE 425 : SEGDES IPINW 426 : SEGDES MELEME 427 : C 428 : COERIG(I10) = 1.D0 429 : IRIGEL(1,I10) = MELEME 430 : IRIGEL(2,I10) = 0 431 : IRIGEL(5,I10) = NIFOUR 432 : IRIGEL(6,I10) = 0 433 : IRIGEL(7,I10) = 2 434 : C création de la matrice élémentaire et du second membre 434 : CALL TOWA1 (REDIR,NOCOPO,NOMDU1,IPINW,NOMPR1, 435 : & MPOVD1,MPOVC1,MPOVR1,MPOVL1,MPOVT1, 436 : & XDT1,DESCR,xMATRI,MCHPO1) 437 : C 438 : IRIGEL(3,I10) = DESCR 439 : IRIGEL(4,I10) = xMATRI 440 : C 441 : SEGACT MCHPO1*MOD 442 : MCHPO1.JATTRI(1) = 2 443 : SEGDES MCHPO1 444 : C 445 : IF (I10.EQ.1) THEN 446 : MCHPOI = MCHPO1 447 : ELSE 447 : CALL FUCHPO (MCHPOI,MCHPO1,IRET1) 448 : MCHPOI = IRET1 449 : ENDIF 450 : C 451 : 10 CONTINUE 452 : C 453 : SEGDES MRIGID 454 : SEGDES IPCEN 455 : SEGSUP REDIR 456 : SEGSUP NOCOPO 457 : C 458 : C Remplissage de la table 459 : C 460 : TYPE = 'RIGIDITE' 460 : CALL ECMO (IPTAB1,'LHS',TYPE,MRIGID) 461 : IF (IERR.NE.0) RETURN 462 : TYPE = 'CHPOINT ' 462 : CALL ECMO (IPTAB1,'RHS',TYPE,MCHPOI) 463 : IF (IERR.NE.0) RETURN 464 : C 465 : END 466 : 467 : 468 :
© Cast3M 2003 - All rights reserved.
Disclaimer