1 : C IMPOS8 SOURCE FANDEUR 11/04/12 21:16:14 6938 2 : 3 : subroutine impos8 4 : 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : 8 : -INC CCOPTIO 9 : -INC SMCOORD 10 : -INC SMELEME 11 : * 12 : SEGMENT icpr(nnoe) 13 : * 14 : PARAMETER ( X1s3 = 0.333333333333333333333333333333333333333333 , 15 : & X1s2 = 0.5 ) 16 : * 17 : character*4 mcle(1) 18 : data mcle /'ESCL'/ 19 : * 20 : * lecture des deux maillages : 21 : * 1er = ligne (MAITRE), 2eme = ligne ou point (ESCLAVE) 22 : * 23 : ipt1 = 0 24 : ipt2 = 0 25 : ippr = 0 26 : icas = 1 27 : * 27 : call lirobj('MAILLAGE',ipt1,1,iretou) 28 : if (ierr.ne.0) return 28 : call lirmot(mcle,1,ire,0) 29 : if (ire.eq.0) then 29 : call erreur(852) 30 : return 31 : endif 31 : call lirobj('MAILLAGE',ipt2,0,iretou) 32 : if (ierr.ne.0) return 33 : if (iretou.eq.0) then 33 : call lirobj('POINT ',ippr,1,iretou) 34 : if (ierr.ne.0) return 35 : ipt2 = ippr 35 : call crelem(ipt2) 36 : endif 37 : * 38 : segact ipt1,ipt2 39 : * 40 : nbel1 = ipt1.num(/2) 41 : nbno1 = ipt1.num(/1) 42 : nbel2 = ipt2.num(/2) 43 : nbno2 = ipt2.num(/1) 44 : * 45 : * Quelques verifications : 45 : if (ipt1.itypel.ne.2) call erreur(853) 46 : if (ipt2.itypel.eq.1) then 47 : icas = 2 47 : if (nbel2.ne.1) call erreur(976) 48 : else 48 : if (ipt2.itypel.ne.2) call erreur(853) 49 : endif 50 : if (ierr.ne.0) goto 9000 51 : * 52 : * Quelques initialisations : 53 : idimp1 = idim+1 54 : nnoe = xcoor(/1) / idimp1 55 : * 56 : nbeele = 0 57 : nbepts = nnoe 58 : nbecoo = (nbepts-1) * idimp1 59 : * 60 : * Branchement en fonction du cas a traiter (variable icas) : 61 : GOTO (1000,2000), icas 61 : call erreur(5) 62 : goto 9000 63 : * 64 : * -------- 65 : * icas = 1 -> MAITRE = ligne (SEG2), ESCLAVE = ligne (SEG2) 66 : * -------- 67 : * Remarque : nbno2 = nbno1 = 2 68 : * 69 : 1000 CONTINUE 70 : * 71 : * estimation du nombre maximal d elements a creer 72 : * 73 : segini icpr 74 : do 100 i=1, nbel1 75 : icpr(ipt1.num(1,i)) = 1 76 : icpr(ipt1.num(2,i)) = 1 77 : 100 continue 78 : do 101 i=1,nbel2 79 : ipv = ipt2.num(1,i) 80 : if (icpr(ipv).eq.1 .or. icpr(ipv).eq.3) then 81 : icpr(ipv) = 3 82 : else 83 : icpr(ipv) = 2 84 : endif 85 : ipv = ipt2.num(2,i) 86 : if (icpr(ipv).eq.1 .or. icpr(ipv).eq.3) then 87 : icpr(ipv) = 3 88 : else 89 : icpr(ipv) = 2 90 : endif 91 : 101 continue 92 : ipo1 = 0 93 : ipo2 = 0 94 : ipo3 = 0 95 : do 102 i = 1, nnoe 96 : if (icpr(i).eq.1) then 97 : ipo1 = ipo1 + 1 98 : elseif (icpr(i).eq.2) then 99 : ipo2 = ipo2 + 1 100 : elseif (icpr(i).eq.3) then 101 : ipo3 = ipo3 + 1 102 : endif 103 : 102 continue 104 : * ipo1m = ipo1 + ipo3 105 : ipo2m = ipo2 + ipo3 106 : nblag = ipo2m * nbel1 107 : segsup icpr 108 : * 109 : * Creation du meleme associe a la relation 110 : * 1 point support a creer pour chaque element genere 111 : * 112 : nbelem = nblag 113 : nbnn = 4 114 : nbsous = 0 115 : nbref = 0 116 : segini,meleme 117 : itypel=22 118 : * 119 : nbpts = nnoe + nblag 120 : segadj mcoord 121 : * 122 : * Boucle sur les elements du 1er maillage (ligne maitre) 123 : * 124 : do 110 iel = 1, nbel1 125 : * 126 : nbeini = nbeele 127 : * 128 : * 1er noeud maitre 129 : * 130 : ip1 = ipt1.num(1,iel) 131 : ipv = (ip1-1)*idimp1 132 : xp1 = xcoor(ipv+1) 133 : yp1 = xcoor(ipv+2) 134 : * 135 : * 2eme noeud maitre dans 136 : * 137 : ip2 = ipt1.num(2,iel) 138 : ipv = (ip2-1)*idimp1 139 : xp2 = xcoor(ipv+1) 140 : yp2 = xcoor(ipv+2) 141 : * 142 : * Boucle sur les points du 2eme maillage (ligne esclave) 143 : * 144 : do 120 jel = 1, nbel2 145 : do 120 jno = 1, nbno2 146 : * 147 : * noeud esclave 148 : * 149 : jp = ipt2.num(jno,jel) 150 : * 151 : * verification que pas relation du noeud esclave sur lui meme 152 : * 153 : if (jp.eq.ip1) goto 120 154 : if (jp.eq.ip2) goto 120 155 : * 156 : * verification que pas deja la relation 157 : * 158 : do 121 irela = nbeini+1, nbeele 159 : if (jp.eq.num(4,irela)) goto 120 160 : 121 continue 161 : * 162 : ipv = (jp-1) * idimp1 163 : xp = xcoor(ipv+1) 164 : yp = xcoor(ipv+2) 165 : * 166 : * xcoor : points supports des mult. et rangement ds melem 167 : * 168 : nbeele = nbeele + 1 169 : nbepts = nbepts + 1 170 : nbecoo = nbecoo + idimp1 171 : * 172 : xcoor(nbecoo+1) = (xp1+xp2+xp) * X1s3 173 : xcoor(nbecoo+2) = (yp1+yp2+yp) * X1s3 174 : xcoor(nbecoo+3) =0. 175 : 176 : num(1,nbeele) = nbepts 177 : num(2,nbeele) = ip1 178 : num(3,nbeele) = ip2 179 : num(4,nbeele) = jp 180 : * 181 : 120 continue 182 : * 183 : 110 continue 184 : * 185 : GOTO 3000 186 : * 187 : * -------- 188 : * icas = 2 -> MAITRE = ligne (SEG2), ESCLAVE = 1 seul point 189 : * -------- 190 : * Remarque : nbno2 = 1, nbno1 = 2 191 : * 192 : 2000 CONTINUE 193 : * 194 : * estimation du nombre maximal d elements a creer 195 : * 196 : nblag = nbel1 + 1 197 : * 198 : * Creation du meleme associe a la relation 199 : * 1 point support a creer pour chaque element genere 200 : * 201 : nbelem = nblag 202 : nbnn = 3 203 : nbsous = 0 204 : nbref = 0 205 : segini,meleme 206 : itypel = 22 207 : * 208 : nbpts = nnoe + nblag 209 : segadj mcoord 210 : * 211 : * noeud esclave 212 : * 213 : jp = ipt2.num(1,1) 214 : ipv = (jp-1)*idimp1 215 : xp = xcoor(ipv+1) 216 : yp = xcoor(ipv+2) 217 : * 218 : * Boucle sur les noeuds du 1er maillage (ligne maitre) 219 : * 220 : do 210 iel = 1, nbel1 + 1 221 : * 222 : nbeini = nbeele 223 : * 224 : * 1er noeud maitre 225 : * 226 : if (iel.gt.nbel1) then 227 : ip1=ipt1.num(2,nbel1) 228 : else 229 : ip1=ipt1.num(1,iel) 230 : endif 231 : ipv = (ip1-1) * idimp1 232 : * 233 : * verification que pas relation du noeud esclave sur lui meme 234 : if (jp.eq.ip1) goto 210 235 : * 236 : * verification que pas deja la relation 237 : do 220 irela = nbeini+1,nbeele 238 : if (jp.eq.num(3,irela)) goto 210 239 : 220 continue 240 : * 241 : xp1 = xcoor(ipv+1) 242 : yp1 = xcoor(ipv+2) 243 : * 244 : * xcoor : points supports des mult. et rangement ds melem 245 : * 246 : nbeele = nbeele + 1 247 : nbepts = nbepts + 1 248 : nbecoo = nbecoo + idimp1 249 : *$ 250 : xcoor(nbecoo+1) = (xp1+xp) * X1s2 251 : xcoor(nbecoo+2) = (yp1+yp) * X1s2 252 : xcoor(nbecoo+3) =0. 253 : * 254 : num(1,nbeele) = nbepts 255 : num(2,nbeele) = ip1 256 : num(3,nbeele) = jp 257 : * 258 : 210 continue 259 : * 260 : * GOTO 3000 261 : * 262 : * ----------------- 263 : * Fin du traitement 264 : * ----------------- 265 : 3000 CONTINUE 266 : * Ajustement au plus juste de meleme et mcoord 267 : if (nbelem.lt.nbeele) then 267 : call erreur(5) 268 : segsup,meleme 269 : goto 9000 270 : elseif (nbelem.gt.nbeele) then 271 : nbelem=nbeele 272 : segadj meleme 273 : nbpts = nbepts 274 : segadj mcoord 275 : endif 276 : segdes,meleme 276 : call ecrobj('MAILLAGE',meleme) 277 : 9000 CONTINUE 278 : segdes,ipt1,ipt2 279 : if (ippr.ne.0) segsup,ipt2 280 : 281 : return 282 : end 283 : 284 :
© Cast3M 2003 - All rights reserved.
Disclaimer