1 : C IMPF SOURCE FANDEUR 11/08/10 21:15:05 7076 2 : * 3 : * Fabrique un maillage : 4 : * - d'elements de frottement a partir d'elements de contact 5 : * - de cables frottants a partir du maillage des cables 6 : * 7 : SUBROUTINE IMPF 8 : * 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-Z) 11 : * 12 : -INC CCOPTIO 13 : * 14 : -INC SMCOORD 15 : -INC SMELEME 16 : * 17 : segment icpr(nbptr) 18 : * 19 : idimp1 = IDIM + 1 20 : * 21 : * Lecture du maillage de contact / des cables frottants 22 : * 22 : call lirobj('MAILLAGE',ipt1,1,iretou) 23 : if (ierr.ne.0) return 24 : * 25 : segact ipt1 26 : * 26 : if (ipt1.lisous(/1) .ne. 0) call erreur(16) 26 : if (ipt1.itypel.ne.22 .and. ipt1.itypel.ne.2) call erreur(16) 27 : if (ierr.ne.0) goto 990 28 : * 29 : nbnnin = ipt1.num(/1) 30 : nbelin = ipt1.num(/2) 31 : * 32 : segact mcoord*mod 33 : nbptin = xcoor(/1) / idimp1 34 : * 35 : *========================================================= 36 : * Elements de frottement <- Elements de contact (type 22) 37 : *========================================================= 38 : if (ipt1.itypel.eq.2) goto 100 39 : * 40 : * Nombre de noeud(s) support(s) supplementaire(s) pour le frottement 41 : * a ajouter a chaque element de contact pour faire l'element de 42 : * frottement correspondant 43 : * Le(s) noeud(s) supplementaire(s) a(ont) les memes coordonnees que 44 : * le noeud support du contact (1er noeud de l'element de contact). 45 : nbs = 1 46 : if (idim.eq.3) nbs = 2 47 : * 48 : segini,meleme=ipt1 49 : nbnn = nbnnin + nbs 50 : nbelem = nbelin 51 : nbref = 0 52 : nbsous = 0 53 : segadj,meleme 54 : * 55 : nbpts = nbptin + (nbs*nbelin) 56 : segadj mcoord 57 : * 58 : do 10 iel = 1, nbelem 59 : ip = (ipt1.num(1,iel)-1) * idimp1 60 : xb = xcoor(ip+1) 61 : yb = xcoor(ip+2) 62 : zb = xcoor(ip+3) 63 : if (idim.eq.3) tb = xcoor(ip+4) 64 : ia = nbptin + nbs*(iel-1) 65 : ip = (ia-1) * idimp1 66 : do 11 in = 1, nbs 67 : ia = ia + 1 68 : ip = ip + idimp1 69 : num(nbnnin+in,iel) = ia 70 : xcoor(ip+1) = xb 71 : xcoor(ip+2) = yb 72 : xcoor(ip+3) = zb 73 : if (idim.eq.3) xcoor(ip+4) = tb 74 : 11 continue 75 : 10 continue 76 : goto 900 77 : 78 : *============================ 79 : * Elements de cable frottant 80 : *============================ 81 : 100 continue 82 : * 83 : * IDIM element(s) de frottement en chaque point geometrique definissant 84 : * le reseau des cables (un seul element associe au noeud commun a 85 : * plusieurs elements de cable pour chaque direction de l'espace) 86 : nbptr = nbptin 87 : segini icpr 88 : nbs = 0 89 : do 101 iel = 1, nbelin 90 : do 102 in = 1, nbnnin 91 : ia = ipt1.num(in,iel) 92 : if (icpr(ia).ne.0) goto 102 93 : nbs = nbs+1 94 : icpr(ia) = nbs 95 : 102 continue 96 : 101 continue 97 : * 98 : nbnn = 2 99 : nbelem = nbs*idim 100 : nbref = 0 101 : nbsous = 0 102 : segini meleme 103 : itypel = 22 104 : * 105 : nbpts = nbptin + (nbs*idim) 106 : segadj,mcoord 107 : * 108 : nbel = 0 109 : ndec = (nbptin-1) * idimp1 110 : do 103 iel = 1, nbelin 111 : do 104 in = 1, nbnnin 112 : ia = ipt1.num(in,iel) 113 : if (icpr(ia).eq.0) goto 104 114 : icpr(ia) = 0 115 : ip = (ia-1)*idimp1 116 : xb = xcoor(ip+1) 117 : yb = xcoor(ip+2) 118 : zb = xcoor(ip+3) 119 : if (idim.eq.3) tb = xcoor(ip+4) 120 : do 105 id = 1,idim 121 : nbel = nbel+1 122 : ndec = ndec+idimp1 123 : xcoor(ndec+1) = xb 124 : xcoor(ndec+2) = yb 125 : xcoor(ndec+3) = zb 126 : if (idim.eq.3) xcoor(ndec+4) = tb 127 : num(1,nbel) = nbptin + nbel 128 : num(2,nbel) = ia 129 : 105 continue 130 : 104 continue 131 : 103 continue 132 : * 133 : segsup icpr 134 : c* goto 900 135 : * 136 : *======= 137 : * Fin : Ecriture du MELEME de frottement 138 : *======= 139 : 900 CONTINUE 140 : segdes,meleme 140 : call ecrobj('MAILLAGE',meleme) 141 : 142 : 990 CONTINUE 143 : segdes,ipt1 144 : 145 : return 146 : end 147 : 148 :
© Cast3M 2003 - All rights reserved.
Disclaimer