C IMPOS8 SOURCE CB215821 25/04/08 21:15:22 12227 subroutine impos8 IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC SMCOORD -INC SMELEME * SEGMENT icpr(nnoe) * PARAMETER ( X1s3 = 0.3333333333333333333333333333333333333333D0 , & X1s2 = 0.5D0 ) * character*4 mcle(1) data mcle /'ESCL'/ * * lecture des deux maillages : * 1er = ligne (MAITRE), 2eme = ligne ou point (ESCLAVE) * ipt1 = 0 ipt2 = 0 ippr = 0 icas = 1 * call lirobj('MAILLAGE',ipt1,1,iretou) if (ierr.ne.0) return call lirmot(mcle,1,ire,0) if (ire.eq.0) then call erreur(852) return endif call lirobj('MAILLAGE',ipt2,0,iretou) if (ierr.ne.0) return if (iretou.eq.0) then call lirobj('POINT ',ippr,1,iretou) if (ierr.ne.0) return ipt2 = ippr call crelem(ipt2) endif * segact ipt1,ipt2 * nbel1 = ipt1.num(/2) nbno1 = ipt1.num(/1) nbel2 = ipt2.num(/2) nbno2 = ipt2.num(/1) * * Quelques verifications : if (ipt1.itypel.ne.2) call erreur(853) if (ipt2.itypel.eq.1) then icas = 2 if (nbel2.ne.1) call erreur(976) else if (ipt2.itypel.ne.2) call erreur(853) endif if (ierr.ne.0) goto 9000 * * Quelques initialisations : idimp1 = idim+1 segact mcoord*mod nnoe = nbpts * nbeele = 0 nbepts = nnoe nbecoo = (nbepts-1) * idimp1 * * Branchement en fonction du cas a traiter (variable icas) : GOTO (1000,2000), icas call erreur(5) goto 9000 * * -------- * icas = 1 -> MAITRE = ligne (SEG2), ESCLAVE = ligne (SEG2) * -------- * Remarque : nbno2 = nbno1 = 2 * 1000 CONTINUE * * estimation du nombre maximal d elements a creer * segini icpr do 100 i=1, nbel1 icpr(ipt1.num(1,i)) = 1 icpr(ipt1.num(2,i)) = 1 100 continue do 101 i=1,nbel2 ipv = ipt2.num(1,i) if (icpr(ipv).eq.1 .or. icpr(ipv).eq.3) then icpr(ipv) = 3 else icpr(ipv) = 2 endif ipv = ipt2.num(2,i) if (icpr(ipv).eq.1 .or. icpr(ipv).eq.3) then icpr(ipv) = 3 else icpr(ipv) = 2 endif 101 continue ipo1 = 0 ipo2 = 0 ipo3 = 0 do 102 i = 1, nnoe if (icpr(i).eq.1) then ipo1 = ipo1 + 1 elseif (icpr(i).eq.2) then ipo2 = ipo2 + 1 elseif (icpr(i).eq.3) then ipo3 = ipo3 + 1 endif 102 continue * ipo1m = ipo1 + ipo3 ipo2m = ipo2 + ipo3 nblag = ipo2m * nbel1 segsup icpr * * Creation du meleme associe a la relation * 1 point support a creer pour chaque element genere * nbelem = nblag nbnn = 4 nbsous = 0 nbref = 0 segini,meleme itypel=22 * nbpts = nnoe + nblag segadj mcoord * * Boucle sur les elements du 1er maillage (ligne maitre) * do 110 iel = 1, nbel1 * nbeini = nbeele * * 1er noeud maitre * ip1 = ipt1.num(1,iel) ipv = (ip1-1)*idimp1 xp1 = xcoor(ipv+1) yp1 = xcoor(ipv+2) * * 2eme noeud maitre dans * ip2 = ipt1.num(2,iel) ipv = (ip2-1)*idimp1 xp2 = xcoor(ipv+1) yp2 = xcoor(ipv+2) * * Boucle sur les points du 2eme maillage (ligne esclave) * do 120 jel = 1, nbel2 do 120 jno = 1, nbno2 * * noeud esclave * jp = ipt2.num(jno,jel) * * verification que pas relation du noeud esclave sur lui meme * if (jp.eq.ip1) goto 120 if (jp.eq.ip2) goto 120 * * verification que pas deja la relation * do 121 irela = nbeini+1, nbeele if (jp.eq.num(4,irela)) goto 120 121 continue * ipv = (jp-1) * idimp1 xp = xcoor(ipv+1) yp = xcoor(ipv+2) * * xcoor : points supports des mult. et rangement ds melem * nbeele = nbeele + 1 nbepts = nbepts + 1 nbecoo = nbecoo + idimp1 * xcoor(nbecoo+1) = (xp1+xp2+xp) * X1s3 xcoor(nbecoo+2) = (yp1+yp2+yp) * X1s3 xcoor(nbecoo+3) =0. num(1,nbeele) = nbepts num(2,nbeele) = ip1 num(3,nbeele) = ip2 num(4,nbeele) = jp * 120 continue * 110 continue * GOTO 3000 * * -------- * icas = 2 -> MAITRE = ligne (SEG2), ESCLAVE = 1 seul point * -------- * Remarque : nbno2 = 1, nbno1 = 2 * 2000 CONTINUE * * estimation du nombre maximal d elements a creer * nblag = nbel1 + 1 * * Creation du meleme associe a la relation * 1 point support a creer pour chaque element genere * nbelem = nblag nbnn = 3 nbsous = 0 nbref = 0 segini,meleme itypel = 22 * nbpts = nnoe + nblag segadj mcoord * * noeud esclave * jp = ipt2.num(1,1) ipv = (jp-1)*idimp1 xp = xcoor(ipv+1) yp = xcoor(ipv+2) * * Boucle sur les noeuds du 1er maillage (ligne maitre) * do 210 iel = 1, nbel1 + 1 * nbeini = nbeele * * 1er noeud maitre * if (iel.gt.nbel1) then ip1=ipt1.num(2,nbel1) else ip1=ipt1.num(1,iel) endif ipv = (ip1-1) * idimp1 * * verification que pas relation du noeud esclave sur lui meme if (jp.eq.ip1) goto 210 * * verification que pas deja la relation do 220 irela = nbeini+1,nbeele if (jp.eq.num(3,irela)) goto 210 220 continue * xp1 = xcoor(ipv+1) yp1 = xcoor(ipv+2) * * xcoor : points supports des mult. et rangement ds melem * nbeele = nbeele + 1 nbepts = nbepts + 1 nbecoo = nbecoo + idimp1 *$ xcoor(nbecoo+1) = (xp1+xp) * X1s2 xcoor(nbecoo+2) = (yp1+yp) * X1s2 xcoor(nbecoo+3) =0. * num(1,nbeele) = nbepts num(2,nbeele) = ip1 num(3,nbeele) = jp * 210 continue * * GOTO 3000 * * ----------------- * Fin du traitement * ----------------- 3000 CONTINUE * Ajustement au plus juste de meleme et mcoord if (nbelem.lt.nbeele) then call erreur(5) segsup,meleme goto 9000 elseif (nbelem.gt.nbeele) then nbelem=nbeele segadj meleme nbpts = nbepts segadj mcoord endif segdes,meleme call ecrobj('MAILLAGE',meleme) 9000 CONTINUE segdes,ipt1,ipt2 if (ippr.ne.0) segsup,ipt2 return end