Télécharger tassp2.eso

Retour à la liste

Numérotation des lignes :

  1. C TASSP2 SOURCE PV 21/01/21 21:15:34 10862
  2. C
  3. SUBROUTINE TASSP2(ITLAC1,ICPR,ICDOUR,ICOLAC,mena)
  4. C======================================================================
  5. C CE SOUS PROGRAMME EST APPELE PAR TASSPO ELIMIN OU CONFON
  6. C
  7. C itlac1 est une list de pointeur sur les maillage arguments
  8. C icpr etabli une correspondance entre la numerotation globale
  9. C des noeuds et une numerotation locale qui tient compte de
  10. C l'elimination
  11. C icdour est le max des valeurs de icpr
  12. C
  13. C MODIF OCTOBRE 1988 PAR PV TRAITE TOUS LES MELEME
  14. C QUE SAUVER SAIT TRAITER
  15. C=====================================================================
  16. implicit integer (i-n)
  17. implicit real*8(a-h,o-z)
  18.  
  19. integer I, I1, I2, I3, IA, IB
  20. integer ICDOUR, mena
  21. integer ICHPOI, ICOMPT
  22. integer IGE, ILG, IMA, IN, IOB, IOU, IP,IPILE, IPREME
  23. integer IRATT, ITL, J, JJ, K, LCONMO, NAL1, NAL2
  24. integer NBEMEL, NBNNAC, NBNNPR, NBPTS, NCONCH, NPM, NSOUPO
  25.  
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC COCOLL
  30. -INC CCNOYAU
  31. -INC CCGEOME
  32. -INC CCPRECO
  33. -INC CCASSIS
  34.  
  35. -INC SMELEME
  36. -INC SMCOORD
  37. POINTEUR MCOOR1.MCOORD
  38. -INC SMTABLE
  39. -INC SMCHAML
  40. -INC TMLCHA8
  41. -INC SMCHPOI
  42. -INC SMNUAGE
  43. -INC TMCOLAC
  44.  
  45. SEGMENT TAB1
  46. REAL*8 XCOOR1(ILG)
  47. ENDSEGMENT
  48. SEGMENT ICPR(0)
  49. SEGMENT ITRAV(NPM)
  50. segment itrav2(nbpts)
  51.  
  52. C Piles de communication MPI
  53. pointeur piles.LISPIL
  54. pointeur jcolac.ICOLAC
  55. pointeur jlisse.ILISSE
  56. pointeur jtlacc.ITLACC
  57. pointeur pile.ITLACC
  58. C
  59. CHARACTER*8 TYPE
  60. C LOGICAL FLAG
  61. DATA NBNNPR/0/
  62. C=====================================================================
  63. iun=1
  64. TYPE=' '
  65. K=-1
  66. C on recupere dans k -npossi, le nombre de type objet possibles
  67. CALL TYPFIL(TYPE,K)
  68. C la pile icolac est cree
  69. CALL CREPIL(ICOLAC,-K)
  70. SEGACT ICOLAC*MOD
  71. ITLACC=KCOLA(1)
  72. ILISSE=ILISSG
  73. segact ilisse*mod
  74. IF (ITLAC1.NE.0) THEN
  75. SEGSUP ITLACC
  76. KCOLA(1)=ITLAC1
  77. ITLACC=KCOLA(1)
  78. C il faut initialiser ilisse sinon on retrouve deux fois les segments
  79. DO 5468 K=1,ITLAC(/1)
  80. IA=ITLAC(K)
  81. IF(IA.EQ.0) GO TO 5468
  82. ILISEG((IA-1)/npgcd)=K
  83. 5468 CONTINUE
  84. ENDIF
  85. C initialisation avec les maillages preconditionnees
  86. do 145 ith=0,nbesc
  87. do ip=1,nbemel
  88. ipreme= premel(ip,ith)
  89. if (ipreme.ne.0) then
  90. call ajoun(itlacc,ipreme,ilisse,iun)
  91. else
  92. goto 145
  93. endif
  94. enddo
  95. 145 continue
  96.  
  97. C preconditionnement des MMODEL et MTABLE ESCLAVES de CCPRECO
  98. DO IIMOD = 1, NMOPAR
  99. IMO = PARMOD(IIMOD)
  100. IF (IMO .EQ. 0) GOTO 143
  101. IES = PESCLA(IIMOD)
  102. C 38 pour les MMODEL
  103. C 10 pour les MTABLE
  104. ITLACC=KCOLA(38)
  105. call ajoun(itlacc,IMO,ilisse,iun)
  106. ITLACC=KCOLA(10)
  107. call ajoun(itlacc,IES,ilisse,iun)
  108. ENDDO
  109. 143 CONTINUE
  110.  
  111. C recupere la list des types des objets en memoire
  112. CALL LISTYP(MLCHA8)
  113. C rempli les piles itlacc avec les objet de type mlcha8
  114. CALL FILLPO(ICOLAC,MLCHA8)
  115. SEGSUP MLCHA8
  116. C reinitialise preconditionnement COMP
  117. do ip = 1,30
  118. precle(ip) = ' '
  119. prepre(ip) = 0
  120. preori(ip) = 0
  121. enddo
  122. C
  123. C complete icolac apres l'examan de chaque pile itlacc
  124. C
  125. CALL FILLPI(ICOLAC)
  126. C
  127. C on ne traite les points que si leur nombre a change
  128. C
  129. segact mcoord*mod
  130. nbnnac = nbpts
  131. nbnnpr=min(nbnnac,nbnnpr)
  132. C write (6,*) 'nb points avant maintenant ',nbnnpr,nbnnac,locerr
  133. if (mena.eq.1) then
  134. if (nbnnac.le.nbnnpr+10000) goto 570
  135. endif
  136. C write (6,*) ' menage complet '
  137. nbnnpr = nbnnac
  138. C
  139. C
  140. C TRAVAILLER SUR LES MELEME
  141. C
  142. C
  143. SEGACT ICOLAC*MOD
  144. ITLACC=KCOLA(1)
  145. ITL=ITLAC(/1)
  146. IF (IIMPI.EQ.9) WRITE(IOIMP,1111) (ITLAC(I),I=1,ITL)
  147. 1111 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  148. C RENUMEROTATION EN FONCTION DU PREMIER OBJET
  149. npm=20
  150. segini itrav,itrav2
  151. * Limitation du nombre de messages erreur(516) à 5 maximum
  152. iresu=1
  153. ims=0
  154. imsmax=5
  155. C
  156. C boucle sur chaque objet de type maillage
  157. icompt=0
  158. DO 10 IOB=1,ITL
  159. MELEME=ITLAC(IOB)
  160. IF (MELEME.EQ.0) goto 10
  161. SEGACT MELEME*MOD
  162. IF (LISOUS(/1).NE.0) GOTO 60
  163. if (num(/1).gt.npm) then
  164. npm=num(/1)
  165. segadj itrav
  166. endif
  167. C boucle sur chaque element
  168. DO 12 I2=1,NUM(/2)
  169. icompt=icompt+1
  170. do 14 i1=1,num(/1)
  171. itrav(i1)=num(i1,i2)
  172. 14 continue
  173. C boucle sur chaque noeud
  174. DO 13 I1=1,NUM(/1)
  175. IP=NUM(I1,I2)
  176. if (ip.ne.0) then
  177. IF (ICPR(IP).EQ.0) THEN
  178. C on affecte un nouveau numero a ce noeud
  179. ICDOUR=ICDOUR+1
  180. ICPR(IP)=ICDOUR
  181. ENDIF
  182. C on change la reference avec le nouveau numero
  183. NUM(I1,I2)=ICPR(IP)
  184. ENDIF
  185. C VERIFICATION PAS DE NOEUDS DOUBLE DANS UN ELEMENT
  186. if (itrav2(icpr(ip)).eq.icompt) then
  187. DO 11 i3=1,i1-1
  188. if (num(i3,i2).eq.num(i1,i2).and.
  189. $ itrav(i1).ne.itrav(i3))then
  190. if (iresu.EQ.1) ims=ims+1
  191. if (ims.LE.imsmax) then
  192. INTERR(1)=NUM(I1,I2)
  193. INTERR(2)=MELEME
  194. INTERR(3)=I2
  195. C on signale la creation d'un noeud double
  196. CALL ERREUR(516)
  197. endif
  198. endif
  199. 11 continue
  200. endif
  201. itrav2(icpr(ip))=icompt
  202. 13 CONTINUE
  203. 12 CONTINUE
  204. 60 CONTINUE
  205. SEGACT,MELEME*NOMOD
  206. 10 CONTINUE
  207. SEGSUP ITRAV,itrav2
  208. if (iresu.eq.1.and.ims.gt.imsmax) then
  209. INTERR(1)=ims-imsmax
  210. CALL ERREUR(1120)
  211. endif
  212. C
  213. C MISE A JOUR DE L'OEIL PAR DEFAUT
  214. C
  215. IF (IOEIL.NE.0) THEN
  216. IF (ICPR(IOEIL).EQ.0) THEN
  217. ICDOUR=ICDOUR+1
  218. ICPR(IOEIL)=ICDOUR
  219. ENDIF
  220. IF (IIMPI.NE.0) WRITE (6,*) ' ANCIEN OEIL ',IOEIL,
  221. > ' NOUVEL OEIL ',ICPR(IOEIL)
  222. IOEIL=ICPR(IOEIL)
  223. ENDIF
  224. C
  225. C MISE A JOUR DE ILGNI si necessaire
  226. C
  227. C* write (6,*) ' tassp2 ilgnio ilgnin ',ilgni,icpr(ilgni)
  228. IF (ILGNI.NE.0) THEN
  229. IF (ICPR(ILGNI).EQ.0) THEN
  230. ICDOUR=ICDOUR+1
  231. ICPR(ILGNI)=ICDOUR
  232. ENDIF
  233. ILGNI=ICPR(ILGNI)
  234. ENDIF
  235. C
  236. C TRAVAILLER SUR LES POINTS DANS LES TABLES (NOUS SOMMES TROP BON)
  237. C
  238. ITLACC=KCOLA(10)
  239. ITL=ITLAC(/1)
  240. IF (IIMPI.EQ.9) WRITE(IOIMP,1112) (ITLAC(I),I=1,ITL)
  241. 1112 FORMAT (/,' LISTE DES TABLES ACCESSIBLES',/,(10I8))
  242. C RENUMEROTATION EN FONCTION DU PREMIER OBJET
  243. DO 110 IOB=1,ITL
  244. MTABLE=ITLAC(IOB)
  245. SEGACT MTABLE*MOD
  246. DO 120 I=1,MLOTAB
  247. IF (MTABTI(I).EQ.'POINT ') THEN
  248. IP=MTABII(I)
  249. IF (IP.EQ.0) write(6,*) 'tassp2 1'
  250. IF (IP.EQ.0) CALL ERREUR(5)
  251. IF (ICPR(IP).EQ.0) THEN
  252. ICDOUR=ICDOUR+1
  253. ICPR(IP)=ICDOUR
  254. ENDIF
  255. MTABII(I)=ICPR(IP)
  256. ENDIF
  257. IF (MTABTV(I).EQ.'POINT ') THEN
  258. IP=MTABIV(I)
  259. if(icpr(IP) .gt.icdour) then
  260. write(6,*) ' pas beau icpr(ip) icdour', icpr(ip) , icdour
  261. CALL ERREUR(5)
  262. endif
  263. IF (IP.EQ.0) write(6,*) 'tassp2 point'
  264. IF (IP.EQ.0) CALL ERREUR(5)
  265. IF (ICPR(IP).EQ.0) THEN
  266. C write(6,*) ' ip icdour ' , ip,icdour
  267. ICDOUR=ICDOUR+1
  268. ICPR(IP)=ICDOUR
  269. ENDIF
  270. MTABIV(I)=ICPR(IP)
  271. ENDIF
  272. 120 CONTINUE
  273. SEGDES MTABLE
  274. 110 CONTINUE
  275. C
  276. C attention a la derniere lecture dans gibiane si c'etait un point!
  277. C
  278. C write(6,*) ' ibpile ,ihpile ', ibpile, ihpile
  279. do ib=ibpile,ihpile
  280. if( jtyobj(ib).eq.'POINT ') then
  281. ip= jpoob4(ib)
  282. C write(6,*) ' on a trouve le point ' , ip
  283. if(icpr(ip).eq.0) then
  284. icdour=icdour+1
  285. icpr(ip)=icdour
  286. endif
  287. jpoob4(ib)=icpr(ip)
  288. endif
  289. enddo
  290. C
  291. C TRAVAILLER SUR LES POINTS DANS LES OBJETS
  292. C
  293. ITLACC=KCOLA(44)
  294. ITL=ITLAC(/1)
  295. IF (IIMPI.EQ.9) WRITE(IOIMP,4112) (ITLAC(I),I=1,ITL)
  296. 4112 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  297. C RENUMEROTATION EN FONCTION DU PREMIER OBJET
  298. DO 4110 IOB=1,ITL
  299. MTABLE=ITLAC(IOB)
  300. SEGACT MTABLE*MOD
  301. DO 4120 I=1,MLOTAB
  302. IF (MTABTI(I).EQ.'POINT ') THEN
  303. IP=MTABII(I)
  304. IF (IP.EQ.0) write(6,*) 'tassp2 2'
  305. IF (IP.EQ.0) CALL ERREUR(5)
  306. IF (ICPR(IP).EQ.0) THEN
  307. ICDOUR=ICDOUR+1
  308. ICPR(IP)=ICDOUR
  309. ENDIF
  310. MTABII(I)=ICPR(IP)
  311. ENDIF
  312. IF (MTABTV(I).EQ.'POINT ') THEN
  313. IP=MTABIV(I)
  314. IF (IP.EQ.0) write(6,*) 'tassp2 3'
  315. IF (IP.EQ.0) CALL ERREUR(5)
  316. IF (ICPR(IP).EQ.0) THEN
  317. ICDOUR=ICDOUR+1
  318. ICPR(IP)=ICDOUR
  319. ENDIF
  320. MTABIV(I)=ICPR(IP)
  321. ENDIF
  322. 4120 CONTINUE
  323. SEGDES MTABLE
  324. 4110 CONTINUE
  325.  
  326. C
  327. C TRAVAll sur les points dans les nuages (grande mansuetude)
  328. C
  329. ITLACC=KCOLA(41)
  330. ITL=ITLAC(/1)
  331. IF (IIMPI.EQ.9) WRITE(IOIMP,1121) (ITLAC(I),I=1,ITL)
  332. 1121 FORMAT (/,' LISTE DES NUAGES ACCESSIBLES',/,(10I8))
  333. DO 7230 IOB=1,ITL
  334. MNUAGE=ITLAC(IOB)
  335. SEGACT MNUAGE
  336. DO 7231 I=1,NUAPOI(/1)
  337. IF(NUATYP(I).EQ.'POINT ')THEN
  338. NUAVIN=NUAPOI(I)
  339. SEGACT NUAVIN*MOD
  340. DO 7233 K=1,NUAINT(/1)
  341. IP=NUAINT(K)
  342. IF (IP.EQ.0) write(6,*) 'tassp2 4'
  343. IF (IP.EQ.0) CALL ERREUR(5)
  344. IF (ICPR(IP).EQ.0) THEN
  345. ICDOUR=ICDOUR+1
  346. ICPR(IP)=ICDOUR
  347. ENDIF
  348. NUAINT(K)=ICPR(IP)
  349. 7233 CONTINUE
  350. SEGDES NUAVIN
  351. ENDIF
  352. 7231 CONTINUE
  353. SEGDES MNUAGE
  354. 7230 CONTINUE
  355.  
  356. C TRAVAILLER SUR LES POINTS DANS LES MCHAML
  357. C (NOUS SOMMES VRAIMENT TROP BONS)
  358. C
  359. ITLACC=KCOLA(39)
  360. ITL=ITLAC(/1)
  361. IF (IIMPI.EQ.9) WRITE(IOIMP,1113) (ITLAC(I),I=1,ITL)
  362. 1113 FORMAT (/,' LISTE DES MCHAMLS ACCESSIBLES',/,(10I8))
  363. C RENUMEROTATION EN FONCTION DU PREMIER OBJET
  364.  
  365. DO 210 IOB=1,ITL
  366. MCHELM=ITLAC(IOB)
  367. if (mchelm.eq.0) goto 210
  368. SEGACT MCHELM
  369. DO 220 I=1,ICHAML(/1)
  370. MCHAML=ICHAML(I)
  371. SEGACT MCHAML*MOD
  372. DO 230 J=1,TYPCHE(/2)
  373. IF(TYPCHE(J).EQ.'POINTEURPOINT ') THEN
  374. MELVAL = IELVAL(J)
  375. IF(MELVAL.LT.0) GO TO 230
  376. SEGACT MELVAL*MOD
  377. NAL1 = IELCHE(/1)
  378. NAL2 = IELCHE(/2)
  379. DO 240 I2=1,NAL2
  380. DO 250 I1=1,NAL1
  381. IP = IELCHE(I1,I2)
  382. if (ip.lt.0) goto 250
  383. IF(IP.EQ.0) then
  384. write(6,*)'tassp2 5',nomche(j),conche(i),imache(i)
  385. CALL ERREUR(5)
  386. endif
  387. IF (ICPR(IP).EQ.0) THEN
  388. ICDOUR=ICDOUR+1
  389. ICPR(IP)=ICDOUR
  390. ENDIF
  391. IELCHE(I1,I2)=-ICPR(IP)
  392. 250 CONTINUE
  393. 240 CONTINUE
  394. SEGACT,MELVAL*NOMOD
  395. IELVAL(J)=-IELVAL(J)
  396. ENDIF
  397. 230 CONTINUE
  398. C PP ON DESACTIVE
  399. SEGACT,MCHAML*NOMOD
  400. 220 CONTINUE
  401. 210 CONTINUE
  402. C on remet tout dans l'etat initial
  403. DO 211 IOB=1,ITL
  404. MCHELM=ITLAC(IOB)
  405. if (mchelm.eq.0) goto 211
  406. DO 221 I=1,ICHAML(/1)
  407. MCHAML=ICHAML(I)
  408. C PP ON REACTIVE
  409. SEGACT MCHAML*MOD
  410. DO 231 J=1,TYPCHE(/2)
  411. IF(TYPCHE(J).EQ.'POINTEURPOINT ') THEN
  412. IELVAL(J)=ABS(IELVAL(J))
  413. MELVAL = IELVAL(J)
  414. SEGACT MELVAL*MOD
  415. NAL1 = IELCHE(/1)
  416. NAL2 = IELCHE(/2)
  417. DO 241 I2=1,NAL2
  418. DO 251 I1=1,NAL1
  419. IELCHE(I1,I2)=abs(IELCHE(I1,I2))
  420. 251 CONTINUE
  421. 241 CONTINUE
  422. SEGDES MELVAL
  423. ENDIF
  424. 231 CONTINUE
  425. SEGACT,MCHAML*NOMOD
  426. 221 CONTINUE
  427. SEGDES,MCHELM
  428. 211 CONTINUE
  429. C
  430. C CAS DE LA DEFORMATION PLANE GENERALISEE :
  431. C Les points supports etant maintenant stockes dans un maillage
  432. C (MELEME) de type POI1 (1 seul element), il n'y a plus de travail
  433. C specifique a realiser. NSDPGE n'est plus utilise aussi.
  434. C
  435. C Pour les CHARGEMENTS, les rares points utilises pour decrire le
  436. C mouvement du chargement sont maintenant stockes dans des maillages
  437. C (MELEME) et ne necessitent donc pas de traitement particulier.
  438. C A noter qu'avant ces points n'etaient pas traites, d'ou un risque de
  439. C probleme, suite a une renumerotation.
  440. C
  441. C travail sur le itlac des points deja sauves
  442. C
  443. IF(IPSAUV.NE.0) THEN
  444. ICOLA1=IPSAUV
  445. SEGACT ICOLA1
  446. ITLAC2=ICOLA1.KCOLA(32)
  447. SEGACT ITLAC2*MOD
  448. IF(ITLAC2.ITLAC(/1).NE.0) THEN
  449. DO 560 K=1,ITLAC2.ITLAC(/1)
  450. If(icpr(ITLAC2.ITLAC(K)).eq.0) then
  451. icdour=icdour+1
  452. icpr(ITLAC2.ITLAC(K))=icdour
  453. endif
  454. ITLAC2.ITLAC(K) = icpr(ITLAC2.ITLAC(K))
  455. 560 CONTINUE
  456. ENDIF
  457. SEGDES ICOLA1,ITLAC2
  458. ENDIF
  459. C
  460. C travail sur les itlac des points communiques
  461. C
  462. if(piComm.gt.0) then
  463. piles=piComm
  464. segact piles
  465. do ipile=1,piles.proc(/1)
  466. jcolac= piles.proc(ipile)
  467. if(jcolac.ne.0) then
  468. segact jcolac
  469. pile = jcolac.kcola(32)
  470. segact pile*mod
  471. if(pile.itlac(/1).ne.0) then
  472. do k=1,pile.itlac(/1)
  473. if(icpr(pile.itlac(k)).eq.0) then
  474. icdour=icdour+1
  475. icpr(pile.itlac(k))=icdour
  476. endif
  477. pile.itlac(k) = icpr(pile.itlac(k))
  478. enddo
  479. endif
  480. segdes jcolac,pile
  481. endif
  482. enddo
  483. segdes piles
  484. endif
  485. C
  486. C ON MET A LA SUITE LES POINTS NOMMES NON DEJA ACCEDES
  487. C POUR COMPLETER LA NOUVELLE LA NUMEROTATION ICPR
  488. DO 50 I=1,LMNNOM
  489. IF (INOOB2(I).NE.'POINT ') GOTO 50
  490. IP=IOUEP2(I)
  491. IF (IP.EQ.0) GOTO 50
  492. IF (ICPR(IP).NE.0) GOTO 51
  493. ICDOUR=ICDOUR+1
  494. ICPR(IP)=ICDOUR
  495. 51 CONTINUE
  496. IOUEP2(I)=ICPR(IP)
  497. 50 CONTINUE
  498. C ICPR CONTIENT LA NOUVELLE NUMEROTATION (LES POINTS A GARDER)
  499. C LES SEGMENTS D'ELEMENTS ONT ETE MIS A JOUR
  500. C DONC TASSER LES POINTS
  501. SEGACT MCOORD*mod
  502. ILG=ICDOUR*(IDIM+1)
  503. SEGINI TAB1
  504. DO 22 I=ICPR(/1),1,-1
  505. IF (ICPR(I).EQ.0) GOTO 22
  506. DO 21 K=1,IDIM+1
  507. XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  508. 21 CONTINUE
  509. 22 CONTINUE
  510. C IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  511. NBPTS=ICDOUR
  512. SEGADJ MCOORD
  513. DO 23 K=1,ILG
  514. XCOOR(K)=XCOOR1(K)
  515. 23 CONTINUE
  516. SEGSUP TAB1
  517. C
  518. C petit travail pour les objets configuration!
  519. C
  520. MCOOR1=MCOORD
  521. ITLACC=KCOLA(33)
  522.  
  523. ITL=ITLAC(/1)
  524. IF (IIMPI.EQ.9) WRITE(IOIMP,1114) (ITLAC(I),I=1,ITL)
  525. 1114 FORMAT (/,' LISTE DES CONFIGURATIONS ACCESSIBLES',/,(10I8))
  526. DO 70 IOB=1,ITL
  527. MCOORD=ITLAC(IOB)
  528. if (mcoord.eq.mcoor1) then
  529. goto 70
  530. endif
  531. SEGACT MCOORD*mod
  532. IMA=xcoor(/1)/(idim+1)
  533. ILG=ICDOUR*(IDIM+1)
  534. SEGINI TAB1
  535. DO 2201 I=ICPR(/1),IMA+1,-1
  536. IF (ICPR(I).EQ.0) GOTO 2201
  537. DO 2101 K=1,IDIM+1
  538. XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=
  539. > MCOOR1.XCOOR((ICPR(I)-1)*(IDIM+1)+K)
  540. 2101 CONTINUE
  541. 2201 CONTINUE
  542. DO 2200 I=MIN(IMA,ICPR(/1)),1,-1
  543. IF (ICPR(I).EQ.0) GOTO 2200
  544. DO 2100 K=1,IDIM+1
  545. XCOOR1((ICPR(I)-1)*(IDIM+1)+K)=XCOOR((I-1)*(IDIM+1)+K)
  546. 2100 CONTINUE
  547. 2200 CONTINUE
  548. C IL FAUT GARDER LE MEME POINTEUR SUR MCOORD
  549. NBPTS=ICDOUR
  550. SEGADJ MCOORD
  551. DO 2300 K=1,ILG
  552. XCOOR(K)=XCOOR1(K)
  553. 2300 CONTINUE
  554. SEGSUP TAB1
  555. SEGDES MCOORD
  556. 70 CONTINUE
  557. MCOORD=MCOOR1
  558. segact mcoord*mod
  559. nbpts=xcoor(/1)/(idim+1)
  560. C on garde icpr pour construire le maillage resultat
  561. C SEGSUP ICPR
  562. C ILP=ICDOUR
  563. C------------------------------------------------------------------
  564. C on travaille sur les champs de points pour signaler le cas
  565. C de points multiples
  566. C
  567. C on recherche les noms des objets
  568. CALL FILLNO(ICOLAC)
  569. C attention fillno desactive icolac
  570. SEGACT ICOLAC*MOD
  571. ITLAC1= KCOLA(1)
  572. ITLACC=KCOLA(2)
  573. SEGACT ITLACC*MOD
  574. ITL=ITLAC(/1)
  575. IF (IIMPI.EQ.9) WRITE(IOIMP,1115) (ITLAC(I),I=1,ITL)
  576. 1115 FORMAT (/,' LISTE DES OBJETS ACCESSIBLES',/,(10I8))
  577. C
  578. NPM = ICDOUR
  579. SEGINI ITRAV
  580. C BOUCLE SUR LES CHAMPS DE POINTS DE LA PILE ITLACC
  581. DO 550 I=1,ITL
  582. MCHPOI=ITLAC(I)
  583. IF (MCHPOI.EQ.0) goto 550
  584. SEGACT MCHPOI
  585. NSOUPO=IPCHP(/1)
  586. C
  587. C BOUCLE SUR LES SOUS CHAMP DE POINTS
  588. DO 520 J=1,NSOUPO
  589. MSOUPO=IPCHP(J)
  590. SEGACT MSOUPO
  591. MELEME=IGEOC
  592. SEGACT MELEME
  593. IF ( LISOUS(/1) .NE. 0 ) GOTO 515
  594. C BOUCLE SUR LES POINTS DU SOUS CHAMP
  595. DO I1=1,NUM(/1)
  596. DO I2=1,NUM(/2)
  597. ITRAV(NUM(I1,I2))=ITRAV(NUM(I1,I2))+1
  598. C ITRAV CONTIENT LE NBRE D'OCCURENCE DE CHAQUE POINT
  599. enddo
  600. enddo
  601. 515 CONTINUE
  602. 520 CONTINUE
  603. C
  604. C Y A T-IL UN NOEUD DOUBLE ?
  605. C
  606. C FLAG = .FALSE.
  607. DO 521 J=1,NSOUPO
  608. MSOUPO=IPCHP(J)
  609. SEGACT MSOUPO
  610. MELEME=IGEOC
  611. SEGACT,MELEME
  612. IF ( LISOUS(/1) .NE. 0 ) GOTO 516
  613. C BOUCLE SUR LES POINTS DU SOUS CHAMP
  614. DO I1=1,NUM(/1)
  615. DO I2=1,NUM(/2)
  616. C
  617. IF (ITRAV(num(i1,i2)) .GT. 1 ) THEN
  618. ICHPOI = MCHPOI
  619. iratt=0
  620. CALL ELCHPO(ICHPOI,iratt)
  621. segact meleme
  622. ITLAC(I)=ICHPOI
  623. IF (Iratt .NE. 0 ) THEN
  624. ISGTR = ICOLA(2)
  625. C le chpoint a t-il un nom
  626. MOTERR =' '
  627. DO 530 JJ=1,ISGTRC(/2)
  628. IF ( ISGTRI(JJ) .EQ. I ) MOTERR = ISGTRC(I)
  629. 530 CONTINUE
  630. C
  631. INTERR(1)= num(i1,i2)
  632. INTERR(2)= MCHPOI
  633. INTERR(3)= ITRAV(num(i1,i2))
  634. CALL ERREUR(622)
  635. c remise a zero de ierr por pouvoir afficher les erreurs suivantes
  636. IERR = 0
  637. ENDIF
  638. ENDIF
  639. ITRAV(num(i1,i2)) = 0
  640. C
  641. enddo
  642. enddo
  643. C SEGDES MELEME
  644. 516 continue
  645. C SEGDES MSOUPO
  646. 521 CONTINUE
  647. c
  648. SEGACT ITLAC1*MOD
  649. MCHPO1=mCHPOI
  650. SEGACT MCHPO1
  651. ILISSE=ILISSG
  652. SEGACT ILISSE*MOD
  653. DO 566 IOU=1,MCHPO1.IPCHP(/1)
  654. MSOUP1=MCHPO1.IPCHP(IOU)
  655. SEGACT MSOUP1
  656. IGE=MSOUP1.IGEOC
  657. CALL AJOUN(ITLAC1,IGE,ILISSE,iun)
  658. C SEGDES MSOUP1
  659. 566 CONTINUE
  660. C SEGDES ILISSE
  661. C SEGDES MCHPO1
  662. C
  663. C SEGDES MCHPOI
  664. 550 CONTINUE
  665. C
  666. SEGsup ITRAV
  667. 570 CONTINUE
  668. segact icolac*mod
  669.  
  670. call chleha(2,0,0,0,0)
  671.  
  672. C------------------------------------------------------------------
  673. C ON APPELLE MAINTENANT MENAG5 POUR FAIRE LE NETTOYAGE DE LA MEMOIRE
  674. C CALL MENAG5(ICOLAC,ITLAC1)
  675. C ON NOTE QUE ITLAC1 N'A PAS ETE DETRUIT (DANS MENAG5)
  676.  
  677. END
  678.  
  679.  
  680.  
  681.  
  682.  
  683.  
  684.  
  685.  
  686.  
  687.  

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