Télécharger la plaquette Cast3M


fr en

Télécharger impos8.eso

Retour à la liste

Numérotation des lignes : 

impos8

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales