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    PV        20/03/24    21:18:05     10554          
  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.333333333333333333333333333333333333333333 ,
  17.      &            X1s2 = 0.5 )
  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 120 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. *
  196.  110  continue
  197. *
  198.       GOTO 3000
  199. *
  200. * --------
  201. * icas = 2 -> MAITRE = ligne (SEG2), ESCLAVE = 1 seul point
  202. * --------
  203. * Remarque : nbno2 = 1, nbno1 = 2
  204. *
  205.  2000 CONTINUE
  206. *
  207. *  estimation du nombre maximal d elements a creer
  208. *
  209.       nblag = nbel1 + 1
  210. *
  211. * Creation du meleme associe a la relation
  212. * 1 point support a creer pour chaque element genere
  213. *
  214.       nbelem = nblag
  215.       nbnn   = 3
  216.       nbsous = 0
  217.       nbref  = 0
  218.       segini,meleme
  219.       itypel = 22
  220. *
  221.       nbpts = nnoe + nblag
  222.       segadj mcoord
  223. *
  224. *     noeud esclave
  225. *
  226.       jp = ipt2.num(1,1)
  227.       ipv = (jp-1)*idimp1
  228.       xp = xcoor(ipv+1)
  229.       yp = xcoor(ipv+2)
  230. *
  231. *  Boucle sur les noeuds du 1er maillage (ligne maitre)
  232. *
  233.       do 210 iel = 1, nbel1 + 1
  234. *
  235.         nbeini = nbeele
  236. *
  237. *         1er noeud maitre
  238. *
  239.         if (iel.gt.nbel1) then
  240.           ip1=ipt1.num(2,nbel1)
  241.         else
  242.           ip1=ipt1.num(1,iel)
  243.         endif
  244.         ipv = (ip1-1) * idimp1
  245. *
  246. *     verification que pas relation du noeud esclave sur lui meme
  247.         if (jp.eq.ip1) goto 210
  248. *
  249. *     verification que pas deja la relation
  250.         do 220 irela = nbeini+1,nbeele
  251.           if (jp.eq.num(3,irela)) goto 210
  252.  220    continue
  253. *
  254.         xp1 = xcoor(ipv+1)
  255.         yp1 = xcoor(ipv+2)
  256. *
  257. *         xcoor : points supports des mult. et rangement ds melem
  258. *
  259.         nbeele = nbeele + 1
  260.         nbepts = nbepts + 1
  261.         nbecoo = nbecoo + idimp1
  262. *$
  263.         xcoor(nbecoo+1) = (xp1+xp) * X1s2
  264.         xcoor(nbecoo+2) = (yp1+yp) * X1s2
  265.         xcoor(nbecoo+3) =0.
  266. *
  267.         num(1,nbeele) = nbepts
  268.         num(2,nbeele) = ip1
  269.         num(3,nbeele) = jp
  270. *
  271.  210  continue
  272. *
  273. *     GOTO 3000
  274. *
  275. * -----------------
  276. * Fin du traitement
  277. * -----------------
  278.  3000 CONTINUE
  279. * Ajustement au plus juste de meleme et mcoord
  280.       if (nbelem.lt.nbeele) then
  281.         call erreur(5)
  282.         segsup,meleme
  283.         goto 9000
  284.       elseif (nbelem.gt.nbeele) then
  285.         nbelem=nbeele
  286.         segadj meleme
  287.         nbpts = nbepts
  288.         segadj mcoord
  289.       endif
  290.       segdes,meleme
  291.       call ecrobj('MAILLAGE',meleme)
  292.  9000 CONTINUE
  293.       segdes,ipt1,ipt2
  294.       if (ippr.ne.0) segsup,ipt2
  295.  
  296.       return
  297.       end
  298.  
  299.  
  300.  
  301.  

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