Télécharger tassp2.eso

Retour à la liste

Numérotation des lignes :

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

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