Télécharger numop2.eso

Retour à la liste

Numérotation des lignes :

  1. C NUMOP2 SOURCE PV 16/06/15 21:15:08 8961
  2. C RACINE DE LA NUMEROTATION POUR LA SORTIE SUR FAC
  3. C
  4. C methode utilisee: NESTED DISSECTION.
  5.  
  6. C ce programme refait l'indicage de la matrice afin de minimiser
  7. C le profil.
  8.  
  9.  
  10. SUBROUTINE NUMOP2(MELEME,ICPR,NODES)
  11. IMPLICIT INTEGER(I-N)
  12. -INC SMELEME
  13. -INC SMCOORD
  14. -INC CCOPTIO
  15. -INC CCASSIS
  16.  
  17. SEGMENT JMEM(NODES+1),JMEMN(NODES+1)
  18. C JMEM et JMEMN contiennent le nombre d'element auquel appartient un noeud
  19.  
  20. SEGMENT JNT(NODES)
  21. C JNT contient la nouvelle numerotation
  22.  
  23. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  24. C ICPR au debut contient l'ancienne numerotation ,
  25. C a la fin la nouvelle.
  26.  
  27. SEGMENT IADJ(NODES+1)
  28. SEGMENT JADJC(0)
  29. C IADJ(i) pointe sur JADJC qui contient les voisins de i entre
  30. C IADJ(i) et IADJ(i+1)-1
  31.  
  32. SEGMENT LAGRAN(NB)
  33. C contient les noeud de lagrange et les noeuds les suivant directement
  34. C cf element de type 22
  35. SEGMENT INVLAG(NB1)
  36.  
  37. SEGMENT BOOLEEN
  38. LOGICAL BOOL(NODES)
  39. ENDSEGMENT
  40. C BOOL(i) = true si le noeud i a ete deja mentionne dans la liste
  41. C des voisins JADJC.
  42.  
  43. SEGMENT IMEMOIR(NBV),LMEMOIR(NBV)
  44. C contient les elements appartenant a chaque noeud,sous forme de liste.
  45.  
  46. INTEGER ELEM
  47. C nom d'un element
  48.  
  49. INTEGER N
  50.  
  51.  
  52. SEGMENT MASQUE
  53. LOGICAL MASQ(NODES)
  54. ENDSEGMENT
  55. C MASQ(X)=.TRUE. si le noeud X n'a pas ete renumerote;
  56. C .FALSE. si il l'a ete.
  57.  
  58. INTEGER DIM,DIMSEP
  59. C DIM= nombre de noeuds renumerotes.
  60.  
  61. INTEGER PIVOT
  62. C PIVOT est le noeud utile a la division du domaine.
  63.  
  64. SEGMENT IPOS(NODES*3)
  65. C est le vecteur contenant la numerotation dans les deux sens,de 1 a NODES
  66. C puis de NODES+1 a 2* NODES, cf la subroutine SEPAR
  67. C
  68. C segments utilisés dans sepa2
  69. C
  70. SEGMENT NRELONG(NODES*nbthr)
  71. C NRELONG contient pour chaque noeud sa profondeur.
  72.  
  73. SEGMENT NOELON(NODES*nbthr)
  74. SEGMENT NOEL2(NODES)
  75. SEGMENT LONDIM(NODES*nbthr)
  76. C NOELON contient les noeuds de profondeur LONG.
  77. C DIMLON= dimension de NOELON.
  78.  
  79.  
  80. C**********************************
  81.  
  82. C debut du program
  83.  
  84. C**********************************
  85.  
  86.  
  87. * pour que izero soit de la bonne longueur
  88. izero=0
  89. C initialisation
  90. C*******************************
  91.  
  92.  
  93. C norme d'erreur
  94. SEGACT ICPR*MOD
  95. NODES=ICPR(/1)
  96. SEGACT MELEME
  97. C icpr: numero des noeuds.
  98. C meleme: objet de maillage (cf assem2.eso)
  99.  
  100. DO 10 I=1,ICPR(/1)
  101. ICPR(I)=0
  102. 10 CONTINUE
  103.  
  104. IPT1=MELEME
  105. IKOU=0
  106. NBV=0
  107. NB1=0
  108. NB2=0
  109.  
  110. DO 100 IO=1,MAX(1,LISOUS(/1))
  111. IF (LISOUS(/1).GT.0) THEN
  112. IPT1=LISOUS(IO)
  113. SEGACT IPT1
  114. ENDIF
  115. C on cree la numerotation des noeuds.
  116. C 'nb noeuds/element'=IPT1.NUM(/1)
  117. C 'nb element'=IPT1.NUM(/2)
  118. IF(abs(IPT1.ITYPEL).EQ.22) THEN
  119. NB1=NB1+IPT1.NUM(/2)
  120. NB2=MAX(NB2,IPT1.NUM(/1))
  121. C NB1= nbre d'éléments de type 22.
  122. C NB2=nbre de noeuds/élément maximum parmi
  123. C les éléments de type 22.
  124. ENDIF
  125. DO 150 J=1,IPT1.NUM(/2)
  126. DO 150 I=1,IPT1.NUM(/1)
  127. IJ=IPT1.NUM(I,J)
  128. C IJ est le Ième noeud du Jème élément.
  129. IF (ICPR(IJ).EQ.0) THEN
  130. C s'il est déjà numéroté, on ne fait rien.
  131. IKOU=IKOU+1
  132. ICPR(IJ)=IKOU
  133. ENDIF
  134. 150 CONTINUE
  135. 100 CONTINUE
  136.  
  137. NODES=IKOU
  138. NB=NB2*NB1
  139.  
  140. C***** initalisation des segments*********
  141.  
  142. SEGINI IADJ,JADJC,JMEM,JMEMN,LAGRAN
  143. SEGINI BOOLEEN,JNT
  144.  
  145. DO 20 I=1,NODES+1
  146. IADJ(I)=0
  147. JMEM(I)=0
  148. JMEMN(I)=0
  149. 20 CONTINUE
  150.  
  151. C******************************************
  152.  
  153. IPT1=MELEME
  154. IADJ(1)=1
  155. INC=0
  156. DO 200 IO=1,MAX(1,LISOUS(/1))
  157.  
  158. IF (LISOUS(/1).NE.0) THEN
  159. IPT1=LISOUS(IO)
  160. ENDIF
  161.  
  162. DO 210 J=1,IPT1.NUM(/2)
  163. IF(abs(IPT1.ITYPEL).EQ.22) THEN
  164. is=sign(1,ipt1.itypel)
  165. DO 220 I=1,IPT1.NUM(/1)
  166. C chaque element de type 22 a au plus NB2 noeuds.
  167. LAGRAN(INC*NB2+I)=ICPR(IPT1.NUM(I,J))*is
  168. C les noeuds de l'elements de type 22
  169. C sont ranges dans le vecteur LAGRAN.
  170. 220 CONTINUE
  171. DO 225 I=IPT1.NUM(/1)+1,NB2
  172. LAGRAN(INC*NB2+I)=0
  173. C comme on a alloue la place memoire maximale,
  174. C on remplit les cases restantes avec des 0.
  175. 225 CONTINUE
  176. INC=INC+1
  177. C INC=le nbre d'elements de type 22.
  178. ENDIF
  179.  
  180. DO 230 I=1,IPT1.NUM(/1)
  181. IJ=ICPR(IPT1.NUM(I,J))+1
  182. JMEM(IJ)=JMEM(IJ)+1
  183. C JMEM(I+1): nb elements auquel le noeud I appartient
  184. 230 CONTINUE
  185. 210 CONTINUE
  186.  
  187. 200 CONTINUE
  188.  
  189.  
  190. JMEM(1)=1
  191. DO 30 I=1,NODES
  192. JMEM(I+1)=JMEM(I)+JMEM(I+1)
  193. C JMEM(I+1)=indice de depart des elements
  194. C auxquels le noeud I appartient.
  195. 30 CONTINUE
  196. NBV=JMEM(NODES+1)
  197. C NBV= dimension de IMEMOIR.
  198. SEGINI IMEMOIR,LMEMOIR
  199.  
  200.  
  201.  
  202. IPT1=MELEME
  203.  
  204. DO 300 IO=1,MAX(1,LISOUS(/1))
  205. IF (LISOUS(/1).NE.0) THEN
  206. IPT1=LISOUS(IO)
  207. ENDIF
  208. DO 350 J=1,IPT1.NUM(/2)
  209. DO 350 I=1,IPT1.NUM(/1)
  210. IJ=ICPR(IPT1.NUM(I,J))
  211. JMEMN(IJ+1)=JMEMN(IJ+1)+1
  212. IMEMOIR(JMEM(IJ)+JMEMN(IJ+1)-1)=J
  213. LMEMOIR(JMEM(IJ)+JMEMN(IJ+1)-1)=IO
  214. C on range dans IMEMOIR tous les elements des sous-objets
  215. C IO auxquels appartient le noeud ICPR(IPT1.NUM(I,J)).
  216. C On connait pour chaque element, le sous-objet auquel
  217. C il appartient grace a LMEMOIR
  218. 350 CONTINUE
  219. 300 CONTINUE
  220.  
  221. DO 410 J=1,NODES
  222. BOOL(J)=.FALSE.
  223. 410 CONTINUE
  224. DO 400 I=1,NODES
  225. IADJ(I+1)=IADJ(I)
  226. DO 420 J=JMEM(I),JMEM(I+1)-1
  227. ELEM=IMEMOIR(J)
  228. C ELEM=element auquel appartient le noeud I.
  229.  
  230. IPT1=MELEME
  231. IF (LISOUS(/1).NE.0) IPT1=LISOUS(LMEMOIR(J))
  232. DO 430 K=1,IPT1.NUM(/1)
  233. C k representatif du nb de noeuds par elements.
  234. IK=ICPR(IPT1.NUM(K,ELEM))
  235. IF ((I.NE.IK).AND.
  236. & (.NOT.(BOOL(IK)))) THEN
  237. C si i n'est pas egal a un des nouveaux numeros des noeuds
  238. C de l'element ELEM et si il n'appartient pas deja a l'ens des
  239. C voisins du noeud i(jadjc(i)),alors on le rajoute.
  240. C JADJC(IADJ(I+1))=IK
  241. JADJC(**)=IK
  242. IADJ(I+1)=IADJ(I+1)+1
  243. BOOL(IK)=.TRUE.
  244. ENDIF
  245. 430 CONTINUE
  246. 420 CONTINUE
  247. * remise a faux de bool
  248. DO 412 J=IADJ(I),IADJ(I+1)-1
  249. IK=JADJC(J)
  250. BOOL(IK)=.FALSE.
  251. 412 CONTINUE
  252. 400 CONTINUE
  253.  
  254. SEGSUP JMEM,JMEMN,IMEMOIR,LMEMOIR,BOOLEEN
  255.  
  256.  
  257.  
  258. C**************************************************************************
  259.  
  260.  
  261. C affectation
  262. C************************
  263.  
  264.  
  265. if (nbthrs.gt.1) call threadii
  266. SEGINI IPOS,MASQUE
  267. IPOSMAX=0
  268.  
  269. DO 50 I=1,NODES
  270. MASQ(I)=.TRUE.
  271. IPOS(I)=0
  272. IPOS(NODES+I)=0
  273. 50 CONTINUE
  274. C initialement, les noeuds ne sont pas masques,ont donc
  275. C une position nulle.
  276.  
  277. DIM=0
  278. C le nombre de noeuds renumerotes DIM est initialement egal a zero.
  279.  
  280.  
  281. C ****************************************
  282. C boucle principale
  283. NS=NODES
  284.  
  285. nbthr=min(64,nbthrs)
  286. SEGINI NRELONG,NOELON,noel2,londim
  287. ** write (6,*) ' avant appel sepa2 '
  288. DO 500 I=1,NODES
  289. 550 IF(.NOT.MASQ(I)) GOTO 500
  290. C si le noeud est masque alors ne rien faire: il est deja
  291. C renumerote. On passe au noeud suivant.
  292.  
  293. PIVOT=I
  294.  
  295. CALL SEPA2(IADJ,JADJC,PIVOT,MASQUE,DIMSEP,NS,
  296. > IPOS,NODES,IPOSMAX,nrelong,noelon,noel2,
  297. > londim,nbthr,izero)
  298. if (ierr.ne.0) return
  299. C separe le domaine d'etude en 2 parties.
  300. C on decrit le domaine d'etude a partir du pivot et on cherche la
  301. C longueur maximale en decrivant les voisins de pivot, et leurs
  302. C voisins... jusqu'a rencontrer un voisin masque. On cree alors
  303. C une nouvelle separation.
  304. C les noeuds masques delimitent la separation du domaine.
  305.  
  306.  
  307. DIM=DIM+DIMSEP
  308. NS=NS-DIMSEP
  309. C la dimension de noeuds renumerotes est augmente de DIMSEP.
  310. C Celle de noeuds a renumeroter est diminue de DIMSEP.
  311.  
  312. * IF (DIM.GE.NODES) GOTO 600
  313. C si tous les noeuds ont ete renumerotes, on arrete.
  314.  
  315. GOTO 550
  316.  
  317. 500 CONTINUE
  318. ** write (6,*) ' apres appel sepa2 '
  319.  
  320. SEGSUP NRELONG,NOELON,noel2,londim
  321.  
  322. 600 CONTINUE
  323. if (nbthrs.gt.1) call threadis
  324. *
  325. * tri dans chaque zone
  326. do 610 lpoint=1,nodes
  327. mdomn=ipos(lpoint+nodes)
  328. iposv=ipos(mdomn+1)
  329. iposi=3*nodes
  330. do 620 kk=iadj(lpoint),iadj(lpoint+1)-1
  331. k=jadjc(kk)
  332. iposk=ipos(ipos(k+nodes)+1)
  333. if (iposk.ne.iposv) then
  334. iposi=min(iposi,iposk)
  335. endif
  336. 620 continue
  337. ipos(lpoint+2*nodes)=iposi
  338. 610 continue
  339.  
  340. *
  341. * mise à la bonne place des multiplicateurs de Lagrange
  342. do 700 J=0,NB1-1
  343. iposvs=2**30
  344. iposvr=-2**30
  345. ipr=0
  346. ips=0
  347. mdomnr=0
  348. mdomns=0
  349. if (nb2.eq.2) goto 700
  350. * write (6,*) 'numop2 ',(lagran(J*NB2+il),il=1,nb2)
  351. do 800 il=3,nb2
  352. ip = abs(LAGRAN(J*NB2+il))
  353. * if (ip.eq.0) write (6,*) ' prob numop2 '
  354. if (ip.eq.0) goto 800
  355. mdomn=ipos(ip+nodes)
  356. iposv=ipos(mdomn+1)
  357. if (iposv.gt.iposvr) then
  358. ipr=ip
  359. iposvr=iposv
  360. mdomnr=mdomn
  361. endif
  362. if (iposv.lt.iposvs) then
  363. ips=ip
  364. iposvs=iposv
  365. mdomns=mdomn
  366. endif
  367. 800 continue
  368. *pv if (ipr.eq.0) write (6,*) ' probleme ipr numop2'
  369. *pv if (ips.eq.0) write (6,*) ' probleme ips numop2'
  370. ip=abs(LAGRAN(J*NB2+2))
  371. IPOS(IP+2*NODES)= 3*nodes+2
  372. * numéroter le frottement apres le contact
  373. if (LAGRAN(J*NB2+1).lt.0) IPOS(IP+2*NODES)=IPOS(IP+2*NODES)+1
  374. IPOS(IP+nodes)=mdomnr
  375. ip=abs(LAGRAN(J*NB2+1))
  376. IPOS(IP+2*NODES)= -2
  377. if (LAGRAN(J*NB2+2).lt.0) IPOS(IP+2*NODES)=IPOS(IP+2*NODES)-1
  378. IPOS(IP+nodes)=mdomns
  379. 700 continue
  380. SEGSUP IADJ,JADJC,MASQUE
  381. * ok maintenant on trie
  382. CALL SORTI2(IPOS,JNT,NODES)
  383.  
  384. C***************************************************************************
  385.  
  386. DO 860 I=1,ICPR(/1)
  387. IF(ICPR(I).NE.0) ICPR(I)=JNT(ICPR(I))
  388. C numerotation finale.
  389. 860 CONTINUE
  390.  
  391.  
  392. SEGSUP JNT,IPOS,LAGRAN
  393.  
  394.  
  395. RETURN
  396. END
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.  
  406.  
  407.  
  408.  
  409.  
  410.  
  411.  
  412.  
  413.  
  414.  
  415.  
  416.  
  417.  
  418.  
  419.  
  420.  

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