Télécharger prtrac.eso

Retour à la liste

Numérotation des lignes :

  1. C PRTRAC SOURCE BP208322 17/04/06 21:15:03 9390
  2. SUBROUTINE PRTRAC
  3. C=======================================================================
  4. C
  5. C CE SOUS PROGRAMME GERE LES TRACES.
  6. C
  7. C IL COMMENCE PAR FABRIQUER L'ENSEMBLE DES SEGMENTS A TRACER EN
  8. C EXTRAYANT LES POINTS UTILES DE L'ENSEMBLE DES POINTS
  9. C
  10. C PUIS IL APPELE LA PROJECTION ET EFFECTUE LE TRACE.
  11. C
  12. C OPTIONS POSSIBLES
  13. C QUALIFIE = TRACE AVEC LES NOMS D'OBJETS
  14. C NOEUDS = TRACE AVEC LES NUMEROS REELS DE NOEU
  15. C ELEMENTS = TRACE AVEC LES NUMEROS D'ELEMENT PAR
  16. C OBJET ELEMENTAIRE
  17. C COULEUR = TRACE UNIQUEMENT LA COULEUR COURANTE
  18. C OU LA COULEUR CHOISIE
  19. C CACHE = TRACE EN "PARTIES VUES-CACHEES"
  20. C ECLATE = TRACE EN ECLATANT LES ELEMENTS
  21. C PEUT ETRE SUIVI PAR UN COEFFICIENT
  22. C FACE = TRACE EN REPRESENTATION PAR FACETTE
  23. C EXCLUT POUR LE MOMENT LES AUTRES OPTIONS
  24. C COUPE = TRACE EN EXCLUANT DE LA REPRESENTATION LA PARTIE
  25. C SITUE PLUS PRES DE L'OBSERVATEUR QU'UN PLAN DONNE
  26. C SECTION = TRACE DE L'INTERSECTION AVEC UN PLAN DONNE
  27. C CHAMP = AFFICHE LA VALEUR DU CHAMP AU POINT SUPPORT
  28. C
  29. C=======================================================================
  30. C
  31. C Modifications :
  32. C
  33. C NOEL 1984 Trace des DEFORMES
  34. C En ce cas lecture non d'une geometrie mais d'un objet DEFORME
  35. C La seule option permise est CACHE
  36. C
  37. C AOUT 1985 Trace d'ISOVALEUR
  38. C Trace les isovaleurs d'un objet de type CHAMPOINT uniquement
  39. C Par defaut on trace 7 isovaleurs
  40. C OPTION : Si prealablement on a cree un objet avec
  41. C l'operateur 'PROG', on peut tracer le nombre d'isovaleurs
  42. C que l'on desire (7 MAXI)
  43. C
  44. C MARS 1986 Introduction de l'option COUPE limitee a la coupe par
  45. C un plan en 3D uniquement
  46. C
  47. C AOUT 1986 Introduction du trace de vecteurs
  48. C
  49. C 1995 Option 'DIRE' et compagnie P.PEGON JRC-ISPRA
  50. C
  51. C FEV 1999 Augmentation des marges autour du dessin
  52. C
  53. C 09/2003 Modifications (temporaires ?) dans le cas IDIM=1.
  54. C
  55. C OCT. 2007 PM :
  56. C .Retournement axe des isovaleurs / amplitude deformee /
  57. C legende vecteurs, contraintes et fissures
  58. C .Couleur des segments marche avec nouvelles couleurs
  59. C .Du fait du passage a 16 couleurs et de la precision des entiers,
  60. C ajout d'une dimension a KON pour specifier le codage de la
  61. C couleur : 0 = une seule, codage normal (anciennement < 300)
  62. C 1 = Possiblement plusieurs, codage binaire par
  63. C puissance de 2 (anciennement > 300)
  64. C .Des nombres en dur lies au nb de couleurs et a l'indice du noir
  65. C passent en parametres
  66. C .Passage du nb de legendes max des vecteurs a 40 (au lieu de 8)
  67. C .Augmentation du nb de legendes de deformees a NDEFMX=40
  68. C auparavant limite en dur a 7
  69. C .Mauvaise identification des elements Navier-Stokes depuis l'ajout de
  70. C nouveaux elements
  71. C
  72. C DEC 2016 SG :
  73. C Ajout d'une option BOITE pour centrer la vue sur un maillage
  74. C donne
  75. C
  76. C MAR 2017 CB215821 :
  77. C Element de SEGMENT passe a la SUBROUTINE AMPINT
  78. C
  79. C=======================================================================
  80. C
  81. C REMARQUES :
  82. C
  83. C Limitation a NLEGMX du nombre de legendes de vecteurs
  84. C
  85. C=======================================================================
  86. C
  87. C VARIABLES :
  88. C
  89. C ICHL : tableau des numero de couleur a prendre pour les deformees
  90. C
  91. C=======================================================================
  92. IMPLICIT INTEGER(I-N)
  93. C IMPLICIT REAL*8 (A-H,O-Z)
  94.  
  95. EXTERNAL LONG
  96. -INC CCREEL
  97. -INC CCOPTIO
  98. -INC CCGEOME
  99. -INC SMELEME
  100. -INC CCNOYAU
  101. -INC CCASSIS
  102. -INC SMDEFOR
  103. -INC SMCHPOI
  104. -INC SMVECTE
  105. -INC SMMODEL
  106. -INC SMCOORD
  107. -INC CCTRACE
  108.  
  109. C Pointeur de sauvegarde du maillage en DIMEnsion 1
  110. POINTEUR ICOORSAV.MCOORD
  111. SEGMENT XCORD(IDIM,ITE)
  112. SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
  113. SEGMENT JCPR(XCOOR(/1)/(IDIM+1))
  114. SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1))
  115. SEGMENT IVU(ITE)
  116. SEGMENT NTSEG(LTSEGS)
  117. SEGMENT KON(3,NBCON,NMAX)
  118. SEGMENT XPROJ(3,ITE)
  119. SEGMENT XPRO2(3,ITE)
  120. SEGMENT KXPRO2(NVEC)
  121. SEGMENT KABEL(0)
  122. SEGMENT KABCOR(0)
  123. SEGMENT LABCO2(3,0)
  124. SEGMENT KABEL2(0)
  125. SEGMENT KABCO3(0)
  126. SEGMENT LABCO3(3,0)
  127. SEGMENT KABCO2(2,0)
  128. SEGMENT ICOR2(0)
  129. SEGMENT KABCPR(0)
  130. SEGMENT KABCP2(0)
  131. SEGMENT MCOUP(0)
  132.  
  133. LOGICAL COUPE,ZDATE,ZCHAM,ZBOIT,ZNOLE
  134. C LOGICAL ZLEGI
  135. REAL DDEC,PDDEC,PYB
  136.  
  137. SEGMENT SDEF
  138. REAL AMPIMP(NDEF)
  139. ENDSEGMENT
  140.  
  141. REAL VCHC(70)
  142. CHARACTER TXTIT*72,TXISO*12,VALISO*12
  143. CHARACTER*72 TITRY,MONMES
  144. CHARACTER*8 TXT
  145. CHARACTER*7 FMTX
  146. CHARACTER*64 ABCDEF
  147. CHARACTER*12 ZONE
  148. CHARACTER*13 LEGEND(10),COMPCH(10)
  149. CHARACTER*10 TMPCAR
  150. CPM NBCOUL-1 au lieu de 8, et IPUIS2
  151. CPV NBCOUL pas connu a la compilation => valeur numerique
  152. INTEGER ICHC(0:30 ),ICHCS(0:30 ),ITEST(0:30 ),
  153. & IPUIS2(0:30 )
  154. PARAMETER (NDEFMX=40)
  155. INTEGER ICHL(NDEFMX)
  156. C+PP (DIRE et FACB et FSDB)
  157. PARAMETER (ISOPT=22)
  158. CHARACTER*4 MSOPT(ISOPT),MOVE(6)
  159. DIMENSION diloc(3)
  160. C+PP
  161. DIMENSION XTR(40),YTR(40),ZTR(40)
  162. DIMENSION PX(4),PY(4)
  163. LOGICAL VALEUR,FENET,BLOCAG,INWDS,INWDS2,CROIX
  164. C probleme optimiseur sur rs6K
  165. SAVE NTSEG
  166. REAL VAMPF
  167. REAL*8 XXX
  168. dimension cgrav(3),axez(3)
  169. C pour les traces de legendes de vecteurs
  170. PARAMETER (NLEGMX=40)
  171. DIMENSION NVCOL(NLEGMX),VAMPF(NLEGMX)
  172. CHARACTER*4 NVLEG(3,NLEGMX)
  173. C+PP + option DIRE et divers FACE
  174. LOGICAL ldire, lndegr, lblanc
  175. C BERTIN: ajout de variable
  176. REAL XB,YB,ZB,XE,YE,ZE,OEBA,XM,YM,ZM,BARY(3),XU,YU,ZU
  177. REAL A,B,C,YHAUT,XHAUT
  178. INTEGER ZCOM,AB,BA,I,K,ISOVU
  179. CHARACTER*72 BUFFER,TIME
  180. CHARACTER*10 VALCH
  181. CHARACTER*4 MODEC(3)
  182. C SG tableau contenant les pointeurs sur tous les maillages lus
  183. PARAMETER(NMAXLU=3)
  184. C IMAILU : index dans le tableau LMAILU
  185. C NMAILU : nombre de maillage effectivent lus
  186. INTEGER IMAILU,NMAILU
  187. INTEGER LMAILU(NMAXLU)
  188. C SG 20160420 dans le coloriage des segments
  189. C icoul : couleur courante (non definie = -3)
  190. C kcoul : couleur voulue
  191. C le but est de n'appeler chcoul que si qqch va etre trace
  192. integer icoul,kcoul
  193. C+PP
  194. DATA ABCDEF( 1:32)/'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdef'/
  195. DATA ABCDEF(33:64)/'ghijklmnopqrstuvwxyz0123456789&@'/
  196. C PP + option DIRE et divers FACE
  197. DATA MSOPT/'QUAL','NOEU','ELEM','CACH','ECLA','COUL','FACE',
  198. * 'COUP','ANIM','OSCI','ARET','TITR','LEGE','NCLK','SECT',
  199. * 'DIRE','FACB','FSDB','DATE','CHAM','BOIT','NOLE'/
  200. DATA MOVE/'SI11','SI22','SI33','FIS1','FIS2','FIS3'/
  201. cbp espacement des legendes des isovaleur (-> nombre maxi NDEC=25 par defaut)
  202. DATA MODEC/'VING','DIX ','CINQ'/
  203.  
  204. C-----------------------------------------------------------------------
  205. C L'operateur TRACER ne marche pas en l'etat pour le cas IDIM=1.
  206. C Astuce : au debut de l'appel a PRTRAC, on recopie le SEGMENT MCOORD
  207. C a 1 DIMENSION dans un segment MCOORD a 2 DIMENSIONs. On effectue
  208. C l'operation inverse lors de la sortie de PRTRAC (GOTO 8900).
  209. C Utiliser IDIMSAV pour savoir si dimension = 1 (0 sinon).
  210. C-----------------------------------------------------------------------
  211. IF (IDIM.EQ.1) THEN
  212. ICOORSAV=MCOORD
  213. IDIMSAV=IDIM
  214. NBPTS=XCOOR(/1)/(IDIMSAV+1)
  215. IDIM=IDIM+1
  216. SEGINI MCOORD
  217. j=IDIM+1
  218. k=IDIMSAV+1
  219. DO i=1,NBPTS
  220. XCOOR((i-1)*j+1)=ICOORSAV.XCOOR((i-1)*k+1)
  221. XCOOR(i*j)=ICOORSAV.XCOOR(i*k)
  222. ENDDO
  223. ELSE
  224. IDIMSAV=0
  225. ENDIF
  226.  
  227. C-----------------------------------------------------------------------
  228. C INITIALISATIONS
  229. C-----------------------------------------------------------------------
  230. sdef =0
  231. ite =0
  232. mlreel=0
  233. LCOMP =0
  234. NCOMP =0
  235. MCARA =0
  236. MCAR1 =0
  237. melemi=0
  238. melei2=0
  239.  
  240. C POUR EVITER DES PROBLEMES UN DEFAUT SUR NCOUMA
  241. NCOUMA=7
  242. BLOCAG=.FALSE.
  243. CROIX =.FALSE.
  244. INWDS =.TRUE.
  245. INWDS2=.TRUE.
  246. ICHISO=0
  247. vchmin= xsgran
  248. vchmax=-xsgran
  249. ipv =0
  250. IPVV =0
  251. melsau=0
  252. mcham =0
  253. VCPCHA=0
  254. IANIM =0
  255. KON =0
  256. ISORT =0
  257. ICLE =0
  258. ITR =1
  259. IVU =0
  260. NTSEG =0
  261. XPROJ =0
  262. XPRO2 =0
  263. KXPRO2=0
  264. IVEC =0
  265. NVECL =0
  266. NBCTS =0
  267. IRETO2=0
  268. KABCOR=0
  269. KABCO2=0
  270. KABCO3=0
  271. LABCO2=0
  272. LABCO3=0
  273. KABEL =0
  274. KABEL2=0
  275. KABCPR=0
  276. KABCP2=0
  277. ICOR2 =0
  278. DIOCA2=REAL(DIOCAD)
  279. TITRY =TITREE
  280. TXTIT =' '
  281. TXISO =' '
  282. VALISO='VAL - ISO'
  283. KCLICK=1
  284. SEGACT MCOORD*MOD
  285. XPRO2 =0
  286. MCOU2 =0
  287. icoup1=0
  288. coupol=-1.
  289. MELEM2=0
  290. MDEFOR=0
  291. NDEF =0
  292. VALEUR=.FALSE.
  293. FENET =.TRUE.
  294. MCOUP =0
  295. NISO =0
  296. IISO =0
  297. IMEL2 =0
  298. IMEL3 =0
  299. ZCOM =0
  300. ZDATE =.FALSE.
  301. ISOVU =-1
  302. ZCHAM =.FALSE.
  303. C ZLEGI =.FALSE.
  304. ZBOIT =.FALSE.
  305. ZNOLE =.FALSE.
  306. VALCH =' '
  307. XHAUT =0.
  308. YHAUT =0.
  309.  
  310. C INIT DU TABLEAU COMPTEUR DE COULEUR
  311. C on ne compte pas le nb de fois que la couleur DEFA (i=0) apparait
  312. DO i=1,NBCOUL-1
  313. ICHC(i)=0
  314. ENDDO
  315. DO i=1,NDEFMX
  316. ICHL(i)=0
  317. ENDDO
  318. CPM precalcul des puissances de 2 : IPUIS2(IC)=2**(IC-1)
  319. IPUIS2(0)=0
  320. K2=1
  321. DO i=1,NBCOUL-1
  322. IPUIS2(i)=K2
  323. K2=K2*2
  324. ENDDO
  325. IICOL=IDCOUL
  326. IDEF=1
  327. IRESU=0
  328. IECLAT=0
  329. IQUALI=0
  330. INUMNO=0
  331. INUMEL=0
  332. ICACHE=0
  333. IFADES=0
  334. IDEFCO=0
  335. IDEFOR=0
  336. IDEFS =0
  337. KDEFOR=0
  338. ICOUP =0
  339. ISECT =0
  340. IARET =0
  341. C+PP + option DIRE et divers FACE
  342. ldire =.FALSE.
  343. lndegr=.FALSE.
  344. lblanc=.FALSE.
  345. C+PP
  346.  
  347. C-----------------------------------------------------------------------
  348. C LECTURE DES PARAMETRES
  349. C-----------------------------------------------------------------------
  350.  
  351. cBP ajout possibilite d'espacer + les legendes avec VING DIX ou CINQ...
  352. CALL LIRMOT(MODEC,3,NDEC2,0)
  353. C PP + option DIRE et divers FACE
  354. 4099 CALL LIRMOT(MSOPT,ISOPT,IR,0)
  355. IF (IR.EQ.0) GOTO 4000
  356. C PP + option DIRE (4016) et divers FACE (4017,4018)
  357. GOTO (4001,4002,4003,4004,4005,4006,4007,4008,4009,4010,4011,
  358. > 4012,4013,4014,4015,4016,4017,4018,4019,4020,4021,4022)
  359. $ ,IR
  360. 4001 IQUALI=1
  361. GOTO 4099
  362. 4002 INUMNO=1
  363. GOTO 4099
  364. 4003 INUMEL=1
  365. GOTO 4099
  366. 4004 ICACHE=1
  367. GOTO 4099
  368. 4005 IECLAT=1
  369. XXX=0.5D0
  370. CALL LIRREE(XXX,0,IRETOU)
  371. XECLAT=REAL(XXX)
  372. GOTO 4099
  373. 4006 IDEFCO=1
  374. CALL LIRMOT(NCOUL,NBCOUL,IICOL,0)
  375. IF (IICOL.EQ.0) IICOL=IDCOUL+1
  376. IICOL=IICOL-1
  377. GOTO 4099
  378. C+PP divers FACE
  379. 4017 lndegr=.TRUE.
  380. 4018 lblanc=.TRUE.
  381. C+PP
  382. 4007 IFADES=1
  383. ICACHE=1
  384. GOTO 4099
  385. 4008 ICOUP=1
  386. GOTO 4099
  387. 4009 IANIM=1
  388. GOTO 4099
  389. 4010 IANIM=2
  390. GOTO 4099
  391. 4011 IARET=1
  392. GOTO 4099
  393. 4012 CALL LIRCHA(TXTIT(1:72),0,IRETOU)
  394. IF (IRETOU.EQ.0) TXTIT=' '
  395. GOTO 4099
  396. 4013 CALL LIRCHA(TXISO(1:12),0,IRETOU)
  397. IF (IRETOU.EQ.0) TXISO=' '
  398. GOTO 4099
  399. 4014 KCLICK=0
  400. GOTO 4099
  401. 4015 ISECT=1
  402. ICOUP=1
  403. GOTO 4099
  404. C+PP + option DIRE (4016)
  405. 4016 ldire=.TRUE.
  406. IF (IDIM.NE.3) ldire=.FALSE.
  407. GOTO 4099
  408. 4019 ZDATE=.TRUE.
  409. GOTO 4099
  410. 4020 continue
  411. ZCHAM=.TRUE.
  412. GOTO 4099
  413. 4021 continue
  414. ZBOIT=.TRUE.
  415. GOTO 4099
  416. 4022 continue
  417. ZNOLE=.TRUE.
  418. GOTO 4099
  419. C+PP
  420. 4000 CONTINUE
  421. C MODIF POUR AUTORISER RIGIDITE A LA PLACE DE GEOMETRIE
  422. CALL LIROBJ('RIGIDITE',III,0,IRETOU)
  423. IF (IRETOU.EQ.1) THEN
  424. CALL ECRCHA('MAILLAGE')
  425. CALL ECROBJ('RIGIDITE',III)
  426. CALL EXTRAI
  427. ENDIF
  428. C
  429. C SG 2016/11/29 On lit tous les maillages ici car on ne sait pas a
  430. C priori combien on va en avoir. En effet, il peut y en avoir 3 avec
  431. C le deuxième facultatif....
  432. C Par contre, après, on est obligé de changer tous les
  433. C LIROBJ(MAILLAGE) et de gérer les erreurs nous-mêmes
  434. C
  435. IMAILU=1
  436. NMAILU=0
  437. DO JJJ=1,NMAXLU
  438. LMAILU(JJJ)=0
  439. ENDDO
  440. 5555 CONTINUE
  441. CALL LIROBJ('MAILLAGE',IGMAI,0,IGRET)
  442. IF (IGRET.EQ.1) THEN
  443. NMAILU=NMAILU+1
  444. IF (NMAILU.GT.NMAXLU) THEN
  445. CALL ERREUR(5)
  446. RETURN
  447. ENDIF
  448. LMAILU(NMAILU)=IGMAI
  449. GOTO 5555
  450. ENDIF
  451. Cdbg WRITE(IOIMP,*) 'NMAILU=',NMAILU
  452. Cdbg WRITE(IOIMP,*) 'LMAILU=',(LMAILU(JJJ),JJJ=1,3)
  453.  
  454. C SG 2016/11/29 : Le maillage boite est le dernier lu
  455. IF (ZBOIT) THEN
  456. C CALL LIROBJ('MAILLAGE',IMBOIT,1,ireto)
  457. C IF (IERR.NE.0) RETURN
  458. IF (NMAILU.GT.0) THEN
  459. IMBOIT=LMAILU(NMAILU)
  460. LMAILU(NMAILU)=0
  461. CALL CHANGE(IMBOIT,1)
  462. ELSE
  463. MOTERR(1:8)='MAILLAGE'
  464. C 37 2 On ne trouve pas d'objet de type %m1:8
  465. CALL ERREUR(37)
  466. RETURN
  467. ENDIF
  468. ENDIF
  469. C
  470. IF (IDIM.EQ.2.OR.IECLAT.EQ.1) THEN
  471. ICACHE=0
  472. ICOUP=0
  473. ENDIF
  474.  
  475. C Lecture du point d'observation et des points de coupe
  476. IF (IDIM.EQ.3) CALL LIROBJ('POINT',IOEI,0,IRETOU)
  477. IF (ICOUP.EQ.1) THEN
  478. CALL LIROBJ('POINT',ICOUP1,1,IRETO)
  479. CALL LIROBJ('POINT',ICOUP2,1,IRETO)
  480. iob=0
  481. if (iretou.eq.0) iob=1
  482. CALL LIROBJ('POINT',ICOUP3,iob,IRETO)
  483. if (ireto.eq.0) then
  484. icoup3=ioei
  485. ioei=0
  486. endif
  487. IF (IERR.NE.0) GOTO 8900
  488. ENDIF
  489.  
  490. C PP + option DIRE
  491. IF (ICOUP.EQ.1.AND.ldire.AND.IOEI.NE.0) THEN
  492. xno1=0.
  493. xno2=0.
  494. psca=0.
  495. do i=1,3
  496. cgrav(i)=REAL(xcoor((ICOUP1-1)*4+i))
  497. diloc(i)=REAL(xcoor((ICOUP2-1)*4+i)) - cgrav(i)
  498. xno1=xno1+(cgrav(i)-REAL(xcoor((IOEI-1)*4+i)))**2
  499. xno2=xno2+ diloc(i)**2
  500. psca=psca+(cgrav(i)-REAL(xcoor((IOEI-1)*4+i)))*diloc(i)
  501. enddo
  502. xno1=SQRT(xno1*xno2)
  503. IF (xno1.LT.1.D-5) then
  504. C Tache impossible. Probablement donnees erronees
  505. CALL ERREUR(26)
  506. ELSE
  507. if (ABS(psca/xno1).GT.0.5D0) THEN
  508. C Tache impossible. Probablement donnees erronees
  509. CALL ERREUR(26)
  510. ENDIF
  511. ENDIF
  512. DO i=1,3
  513. diloc(i)=diloc(i)/SQRT(xno2)
  514. ENDDO
  515. ELSE
  516. do i=1,3
  517. cgrav(i)=0.
  518. diloc(i)=0.
  519. enddo
  520. ENDIF
  521. C PP
  522. C en l'absence d'oeil specifie, on en met un par defaut
  523. IF (IDIM.EQ.3) THEN
  524. IF (IOEI.NE.0) IOEIL=IOEI
  525. IF (IOEIL.EQ.0) THEN
  526. C il n'y a meme pas d'oeil par defaut
  527. NBPTS=XCOOR(/1)/4+1
  528. SEGADJ MCOORD
  529. IOEIL=NBPTS
  530. XCOOR((IOEIL-1)*4+1)= 1.0D6
  531. XCOOR((IOEIL-1)*4+2)=-1.2D6
  532. XCOOR((IOEIL-1)*4+3)= 0.9D6
  533. XCOOR((IOEIL-1)*4+4)= 1
  534. ENDIF
  535. ENDIF
  536. IF (IERR.NE.0) GOTO 8900
  537. IOEINI=IOEIL
  538.  
  539. C-----------------------------------------------------------------------
  540. C LECTURE de VECTEUR et/ou de DEFORME
  541. C-----------------------------------------------------------------------
  542.  
  543. C -VECTEUR ?
  544. MVECTE=0
  545. MVECTS=MVECTE
  546. CALL LIROBJ('VECTEUR ',MVECTE,0,IRETO1)
  547. MVECTS=MVECTE
  548. IF (MVECTE.NE.0) THEN
  549. C SG 2016/11/29 CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  550. IF (IMAILU.GT.NMAXLU) THEN
  551. CALL ERREUR(5)
  552. RETURN
  553. ELSE
  554. MELEME=LMAILU(IMAILU)
  555. IMAILU=IMAILU+1
  556. IF (MELEME.EQ.0) THEN
  557. MOTERR(1:8)='MAILLAGE'
  558. C 37 2 On ne trouve pas d'objet de type %m1:8
  559. CALL ERREUR(37)
  560. ENDIF
  561. ENDIF
  562. IF (IERR.NE.0) GOTO 8900
  563. SEGACT MVECTE
  564. ENDIF
  565.  
  566. C -DEFORME ?
  567. MDEFOR=0
  568. IF (MVECTE.EQ.0) CALL LIROBJ('DEFORME ',MDEFOR,0,IRETO2)
  569. IDEFOR=IRETO2
  570. IF (IDEFOR.NE.0) THEN
  571. C RECHERCHE UNE SECONDE DEFORMEE (CAS TRACE ARETE )
  572. CALL LIROBJ('DEFORME',MDEFO1,0,IMEL3)
  573. C STOP SI TRACE ARETE DE DEFORME (CAS OU IL EN MANQUE UNE)
  574. IF (IDEFOR.NE.0 .AND. IARET.NE.0 .AND. IMEL3.EQ.0) GOTO 8900
  575. SEGACT MDEFOR
  576. ENDIF
  577.  
  578. C PRENDRE LE BON TITRE SI IL Y A LIEU
  579. MCHPOI=0
  580. IF (MVECTE.NE.0) THEN
  581. MCHPOI=ICHPO(1)
  582. ENDIF
  583. IF (MDEFOR.NE.0) THEN
  584. MCHPOI=ICHDEF(1)
  585. ENDIF
  586. IF (MCHPOI.NE.0) THEN
  587. VALEUR=.TRUE.
  588. SEGACT MCHPOI
  589. IF(MOCHDE(1:12).NE.' ') THEN
  590. READ (MOCHDE,FMT='(A8)') IPVV
  591. IF (IPVV.NE.0) THEN
  592. TITRY=MOCHDE
  593. ENDIF
  594. ENDIF
  595. SEGDES MCHPOI
  596. ENDIF
  597.  
  598. C-----------------------------------------------------------------------
  599. C LECTURE D'UN CHPOINT ou d'un MCHAML
  600. C POUR LE TRACE DES ISOVALEURS DE CELUI-CI
  601. C-----------------------------------------------------------------------
  602.  
  603. C MISE A 1 DU FLAG IRETOU POUR INDIQUER CETTE EXISTENCE
  604. CALL LIROBJ('CHPOINT ',MCHPOI,0,IRETO3)
  605. c-----debut du cas ou on n'a pas lu de chpoint : lecture d'un mchaml
  606. IF (IRETO3.EQ.0) THEN
  607. C ICONV=0
  608. CALL LIROBJ('MCHAML',IPIN,0,IRETO3)
  609. IF (IRETO3.EQ.1) THEN
  610. CALL LIROBJ('MMODEL',IPMO1,1,IRETT1)
  611. IF (IRETT1.EQ.0) GOTO 8900
  612.  
  613. CALL REDUAF(IPIN,IPMO1,MCHA1,0,IR,KER)
  614. IF(IR .NE. 1) CALL ERREUR(KER)
  615. IF(IERR .NE. 0) RETURN
  616.  
  617. C ENLEVER EVENTUELLEMENT LA PARTIE FROTTEMENT DU MODELE et les relations
  618. C de conformite
  619. MMODE1=IPMO1
  620. SEGINI,MMODEL=MMODE1
  621. N1=0
  622. NS1=0
  623. DO 4300 I=1,KMODEL(/1)
  624. IMODEL=KMODEL(I)
  625. SEGACT IMODEL
  626. C FRO3
  627. IF (NEFMOD.EQ.107) GOTO 4300
  628. C FRO4
  629. IF (NEFMOD.EQ.165) GOTO 4300
  630. C MULT
  631. IF (NEFMOD.EQ.22) GOTO 4300
  632. C Navier_stokes
  633. CPM ceux apres 258 ne sont plus du NS
  634. IF (NEFMOD.GE.195.AND.NEFMOD.LE.258) NS1=1
  635. N1=N1+1
  636. KMODEL(N1)=IMODEL
  637. 4300 CONTINUE
  638. SEGADJ MMODEL
  639. IPMO1=MMODEL
  640. C -TRAITEMENT SPECIAL POUR NAVIER_STOKES
  641. IF(NS1.EQ.1) THEN
  642. CALL CHASPG(IPMO1,MCHA1,MCHAM,IRET,1)
  643. IF (IRET.NE.0) MCHAM=MCHA1
  644. ELSE
  645. C -SINON PASSER LES CHAMELEM AUX NOEUDS
  646. CALL CHASUP(IPMO1,MCHA1,MCHAM,IRET,1)
  647. IF (IRET.NE.0) MCHAM=MCHA1
  648. C lecture eventuelle d'un champ de caracteristiques (poutres, etc ...)
  649. CALL LIROBJ('MCHAML',IPIN,0,IRET)
  650. mcara=IPIN
  651. IF (IRET.EQ.1) THEN
  652. CALL REDUAF(IPIN,IPMO1,MCAR1,0,IR,KER)
  653. IF(IR .NE. 1) CALL ERREUR(KER)
  654. IF(IERR .NE. 0) RETURN
  655. CALL CHASUP(IPMO1,MCAR1,MCARA,IRET,1)
  656. ENDIF
  657. ENDIF
  658. C -FIN DE LA DISTINCTION NAVIER_STOKES / AUTRES CAS
  659. C on ne les transforme plus en champoint. On travaille
  660. C directement dessus
  661. C CALL CHAMPO(MCHAM,1,MCHPOI,IY)
  662. C IF(IRET.EQ.0) CALL DTCHAM(MCHAM)
  663. C IF (ICONV.EQ.1) THEN
  664. C CALL DTMODL(IPMO1)
  665. C IF (IRET.EQ.0) CALL DTCHAM(MCHA1)
  666. C ENDIF
  667. ENDIF
  668. IF (IERR.NE.0) GOTO 8900
  669. ENDIF
  670. c-----fin du cas ou on n'a pas lu de chpoint : lecture d'un mchaml
  671.  
  672. C TRACE DES ISOVALEURS ? oui (ICHISO=1) si :
  673. C - il y a effectivement un chpoint ou un mchaml
  674. IF (IRETO3.EQ.1) THEN
  675. ICHISO=IRETO3
  676. cbp VALEUR=.TRUE.
  677. cbp si NO LEgende, alors on ne decale pas
  678. VALEUR=.NOT.ZNOLE
  679. ENDIF
  680. C - il y a au moins 1 deformee qui contient un chpoint
  681. IF (IDEFOR.EQ.1) THEN
  682. SEGACT MDEFOR
  683. NDEF=AMPL(/1)
  684. segini,sdef
  685. DO I=1,NDEF
  686. IF(MDCHP(I).NE.0.OR.MDCHEL(I).NE.0) ICHISO=1
  687. C (fdp) Initialisation des coef d'amplification imposes pour le trace
  688. C a partir de ceux contenus dans les objets deformees
  689. AMPIMP(I)=AMPL(I)
  690. C (fdp) S'il n'y a qu'une deformee a tracer et que l'on a modifie
  691. C l'amplification via l'interface de trace, alors on reprend
  692. C cette valeur saisie (stockee dans le COMMON AMPLIT)
  693. IF ((NDEF.EQ.1).AND.(AMPLIT.LT.XSGRAN/2.)) AMPIMP(I)=AMPLIT
  694. ENDDO
  695. ENDIF
  696.  
  697.  
  698. C-----------------------------------------------------------------------
  699. C INIT ENVIRONNEMENT GRAPHIQUE
  700. C-----------------------------------------------------------------------
  701.  
  702. C point de rebranchement apres nouveau point de vu
  703. 4210 CONTINUE
  704. NBPTS=XCOOR(/1)/(IDIM+1)
  705. CALL TREFF
  706. IF(TXTIT.NE.' ') TITRY=TXTIT
  707. CALL TRINIT(25,DIOCA2,DIOCA2,TITRY,0.15,VALEUR,NCOUMA)
  708. CALL TRCLIK(KCLICK)
  709. C
  710. IF (MDEFOR.EQ.0.AND.MVECTE.EQ.0) GOTO 6000
  711. C---- C'EST UNE DEFORMEE OU UN VECTEUR QUE L'ON VEUT FAIRE -------------
  712.  
  713. C ON ANNULE LES OPTIONS INCOMPATIBLES
  714. IQUALI=0
  715. INUMNO=0
  716. INUMEL=0
  717. IDEFCO=0
  718. IECLAT=0
  719. C IFADES=0 CAS A DISCUTER ????
  720.  
  721. C-----------------------------------------------------------------------
  722. C EXTRAIT DES DEFORMES LE MAILLAGE, LES COORD. POINTS ...
  723. C-----------------------------------------------------------------------
  724. 1234 IF (MDEFOR.NE.0) THEN
  725. CALL CREDEF(KABEL,KABCOR,KABCPR,MDEFOR,LABCO2,sdef )
  726. IF (IMEL3.NE.0) CALL CREDEF(KABEL2,KABCO3,KABCP2,MDEFO1,LABCO3,
  727. > sdef )
  728. ENDIF
  729. IF (MVECTE.NE.0) CALL CREVEC(MELEME,ICPR,KABCOR,LABCO2,MVECTE,0)
  730.  
  731. C-----------------------------------------------------------------------
  732. C CALCUL DU CADRE AVANT DE CYCLER SUR LA SUITE (EN MODIFIANT PROJEC)
  733. C SUR LA DEFORMEE PRINCIPALE
  734. C-----------------------------------------------------------------------
  735.  
  736. C PP + option DIRE
  737. CALL CADRCL(KABCOR,LABCO2,IOEIL,XPROJ,
  738. * 0,XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT,cgrav,diloc,ldire,axez)
  739. Cgoo WRITE(IOIMP,*) 'PRTRAC : XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT=',
  740. Cgoo $ XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT
  741. C TRACER CARRE FAIT DANS TRINIT SI NECESSAIRE
  742. XMIN=XMINT
  743. XMAX=XMAXT
  744. C XMAX=MAX(XMAXT,XMIN+YMAXT-YMINT,XMIN+ZMAXT-ZMINT)
  745. YMIN=YMINT
  746. YMAX=YMAXT
  747. C YMAX=MAX(YMAXT,YMIN+XMAXT-XMINT,YMIN+ZMAXT-ZMINT)
  748. ZMIN=ZMINT
  749. ZMAX=ZMAXT
  750. C ZMAX=MAX(ZMAXT,ZMIN+XMAXT-XMINT,ZMIN+XMAXT-XMINT)
  751. C Modif des marges
  752. C Ancien :
  753. C XDEC=(XMAX-XMIN)*0.01
  754. C Nouveau :
  755. XDEC=(XMAX-XMIN)*0.1
  756. XMAX=XMAX+XDEC
  757. YMAX=YMAX+XDEC
  758. ZMAX=ZMAX+XDEC
  759. XMIN=XMIN-XDEC
  760. YMIN=YMIN-XDEC
  761. ZMIN=ZMIN-XDEC
  762. IF (IRESU.NE.1) THEN
  763. IF (ZBOIT) THEN
  764. CALL PROJC2(IMBOIT,IOEIL,CGRAV,XBMIN,XBMAX,YBMIN
  765. $ ,YBMAX,ZBMIN,ZBMAX)
  766. XMI=XBMIN
  767. XMA=XBMAX
  768. YMI=YBMIN
  769. YMA=YBMAX
  770. ZMI=ZBMIN
  771. ZMA=ZBMAX
  772. ELSE
  773. XMI=XMIN
  774. XMA=XMAX
  775. YMI=YMIN
  776. YMA=YMAX
  777. ZMI=ZMIN
  778. ZMA=ZMAX
  779. ENDIF
  780. ENDIF
  781. CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET)
  782.  
  783.  
  784. C-----------------------------------------------------------------------
  785. C
  786. C ON BOUCLE SUR LES DEFORMES (OU LES VECTEURS)
  787. C
  788. C-----------------------------------------------------------------------
  789.  
  790. C INITIALISATION de NDEF et NVEC
  791. IF (MDEFOR.NE.0) THEN
  792. SEGACT MDEFOR
  793. NDEF=KABCPR(/1)
  794. C dans le cas isovaleur sur chpoint (ou mchaml) = syntaxe 4,
  795. C 1 seule deformee est utilisee
  796. IF (IRETO3.EQ.1) NDEF=1
  797. IF (IANIM.NE.0) CALL TRANIM(IANIM,NDEF)
  798. ENDIF
  799. IDEFOR=NDEF
  800. KDEFOR=NDEF
  801. IF (MVECTE.NE.0) THEN
  802. SEGACT MVECTE
  803. NVEC=AMPF(/1)
  804. NDEF=1
  805. IDEFOR=NVEC
  806. ENDIF
  807.  
  808. C d'abord on calcule si necessaire le min et max general
  809. vchmin=xsgran
  810. vchmax=-xsgran
  811. if (mdefor.ne.0.and.ichiso.ne.0.and.mlreel.eq.0)
  812. > CALL vchbor(mdefor,1,NDEF,vchmin,vchmax)
  813. if(iimpi.ge.666) write(ioimp,*) 'vchmin,vchmax=',vchmin,vchmax
  814.  
  815. IDEF=0
  816. C>>>> DEBUT DE LA BOUCLE PRINCIPALE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  817. 6099 CONTINUE
  818. IDEF=IDEF+1
  819. IF (IDEF.GT.NDEF) GOTO 6100
  820. if(iimpi.ge.666) write(ioimp,*) '------IDEF=',IDEF,' /',NDEF
  821. if(iimpi.ge.666) write(ioimp,*) 'ICHISO,NISO=',ICHISO,NISO
  822.  
  823. c cas animation
  824. IF (IANIM.NE.0) CALL TRIMAG(IDEF)
  825.  
  826. c cas deformee
  827. IF (MDEFOR.NE.0) THEN
  828. VCHC(MIN(NDEFMX,IDEF))=REAL(AMPL(MIN(NDEFMX,IDEF)))
  829. C POUR AFFICHER CORRECTEMENT DEFORME SUR ISOVALEUR
  830. SIAMPL=REAL(AMPL(IDEF))
  831. IF(AMPIMP(IDEF).LT.XSGRAN/2.)SIAMPL=AMPIMP(IDEF)
  832. ICHL(MIN(NDEFMX,IDEF))=JCOUL(MIN(NDEFMX,IDEF))
  833. KSCDEF=JCOUL(MIN(NDEFMX,IDEF))
  834. ENDIF
  835. IF (MDEFOR.NE.0) THEN
  836. ICPR=KABCPR(IDEF)
  837. MELEME=KABEL(IDEF)
  838. XCORD=KABCOR(IDEF)
  839. ITE=XCORD(/2)
  840. cbp IF (MDCHP(IDEF).NE.0) MCHPOI=MDCHP(IDEF)
  841. cbp IF (MDCHEL(IDEF).NE.0) MCHAM=MDCHEL(IDEF)
  842. cbp IF (MDMODE(IDEF).NE.0) IPMO1=MDMODE(IDEF)
  843. c on ne recupere le chpoint d isovaleur de la deformee
  844. c que si pas de chpoint explicitement fourni
  845. IF (IRETO3.EQ.0) THEN
  846. SEGACT MDEFOR
  847. MCHPOI=MDCHP(IDEF)
  848. MCHAM=MDCHEL(IDEF)
  849. IPMO1=MDMODE(IDEF)
  850. ENDIF
  851. ENDIF
  852. if(iimpi.ge.666) write(ioimp,*) 'MCHPOI=',MCHPOI
  853.  
  854. c recup du MELEME et du KABEL si DEFORMES ou de CREVEC si VECTEURS
  855. IPT1=MELEME
  856. if (ite.eq.0) ITE=ICPR(/1)
  857. C GOTO 6010
  858.  
  859. C---- POINT D'ARRIVEE EN L'ABSENCE DE DEFORMES ET DE VECTEURS ----------
  860. 6000 CONTINUE
  861.  
  862. IISO=0
  863. IF (ICHISO.EQ.1) THEN
  864. cbp NISO=1
  865. cbp on introduit IISO
  866. cbp =1 si il y a un champ d isovaleur pour cette ieme deformee
  867. IF(MCHPOI.ne.0.or.mcham.ne.0) IISO=max(1,NISO)
  868. C On ne sait indiquer les isovaleurs que sur une seule deformee
  869. C IF (NDEF.GT.1) CALL ERREUR(283)
  870. IF (IERR.NE.0) GOTO 8900
  871. IF (ISOTYP.GT.0.AND.IDIM.EQ.3) ICACHE=1
  872. ENDIF
  873.  
  874. c les operations suivantes ne doivent etre realisee qu'une seule
  875. c fois, sinon on saute en 6011
  876. IF (IDEF.NE.1) GOTO 6011
  877. if (ipv.eq.0) then
  878.  
  879. C-----------------------------------------------------------------------
  880. C LECTURE MAILLAGE PRINCIPAL (sauf cas deformee et chamelem)
  881. C-----------------------------------------------------------------------
  882. IF (IDEFOR.EQ.0.and.mcham.eq.0) THEN
  883. C SG 2016/11/29 CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  884. IF (IMAILU.GT.NMAXLU) THEN
  885. CALL ERREUR(5)
  886. RETURN
  887. ELSE
  888. MELEME=LMAILU(IMAILU)
  889. IMAILU=IMAILU+1
  890. IF (MELEME.EQ.0) THEN
  891. MOTERR(1:8)='MAILLAGE'
  892. C 37 2 On ne trouve pas d'objet de type %m1:8
  893. CALL ERREUR(37)
  894. ENDIF
  895. ENDIF
  896. IF (IERR.NE.0) GOTO 8900
  897. melsau=meleme
  898. ENDIF
  899. C-----------------------------------------------------------------------
  900. C LECTURE EVENTUELLE D'UN 2ND MAILLAGE
  901. C-----------------------------------------------------------------------
  902. C SG 2016/11/29 CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
  903. IF (IMAILU.GT.NMAXLU) THEN
  904. CALL ERREUR(5)
  905. RETURN
  906. ELSE
  907. MELEM2=LMAILU(IMAILU)
  908. IMAILU=IMAILU+1
  909. IRETOU=1
  910. IF (MELEM2.EQ.0) IRETOU=0
  911. ENDIF
  912. IMEL2=IRETOU
  913. IF (IMEL2.EQ.0.AND.IARET.EQ.1.AND.IDEFOR.EQ.0) GOTO 8900
  914. c IF (MDEFOR.EQ.0) then
  915. C mdefos=mdefor
  916. C MDEFOR=MELEME
  917. c endif
  918. CALL REFUS
  919.  
  920. endif
  921. 6011 CONTINUE
  922.  
  923. C POUR ETRE L'IDENTITE SUR L'OBJET
  924.  
  925. C-----------------------------------------------------------------------
  926. C INTERPOLATION CAS DES ISO
  927. C-----------------------------------------------------------------------
  928.  
  929. cbp IF (NISO.NE.0) THEN
  930. IF (ICHISO.EQ.1) THEN
  931. C ici on rajoute une structure recevant les chamelems
  932. if(VCPCHA.ne.0) segsup,VCPCHA
  933. VCPCHA = 0
  934. if(MCHPOI.ne.0.or.mcham.ne.0) then
  935. SEGINI VCPCHA
  936. cbp cas chpoint fourni (a 1 ou plus composantes), on reinitialise
  937. if (IRETO3.eq.1) then
  938. vchmin=xsgran
  939. vchmax=-vchmin
  940. endif
  941. CALL AVISO(MELEME,MCHPOI,mcham,ipmo1,VCPCHA,VCHC,NISO,NCOUMA,
  942. > VCHMIN,VCHMAX,MLREEL,MCARA,NCOMP,LCOMP,COMPCH,ISOVU)
  943. if(iimpi.ge.666) write(ioimp,*) 'AVISO -> NISO=',NISO
  944. & ,'VCHMIN,VCHMAX=',VCHMIN,VCHMAX
  945. IF (IERR.NE.0) GOTO 8900
  946. endif
  947. ENDIF
  948. if(iimpi.ge.666) write(ioimp,*) 'VCPCHA=',VCPCHA
  949.  
  950. C-----------------------------------------------------------------------
  951. C CAS D'UNE COUPE
  952. C-----------------------------------------------------------------------
  953.  
  954. IF (ICOUP.EQ.1) THEN
  955. if (melemi.eq.0) melemi=meleme
  956. if (melei2.eq.0) melei2=melem2
  957. C write(6 ,*) ' on doit faire une coupe '
  958. IF (IDEFOR.EQ.0.AND.MVECTE.EQ.0) THEN
  959. CALL CRCOUP(IOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCPCHA,
  960. * MELEM2,MCOU2,mcham,isect)
  961. ELSE
  962. KABC=KABCOR(IDEF)
  963. XCORD=KABC
  964. SEGACT XCORD
  965. NBCTS=XCORD(/2)
  966. ITE=NBCTS
  967. C INITIALISATION DE IVU (UN ELEMENT PAR POINT)
  968. C IVU=1 POINT VU (EN CAS DE COUPE )
  969. C IVU<>1 POINT PAS VU
  970. SEGINI IVU
  971. DO 5000 I=1,ITE
  972. IVU(I)=1
  973. 5000 CONTINUE
  974. CALL CRCOU2(IOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCPCHA,
  975. * KABC,ICPR,MELEM2,MCOU2,ITE,IVU,mcham,isect)
  976. ENDIF
  977. ENDIF
  978.  
  979. C 3001 CONTINUE
  980.  
  981. C -ON SAUTE CETTE PARTIE SI DEFORMEE OU VECTEURS
  982. IF (IDEFOR.NE.0.OR.MVECTE.NE.0) GOTO 6010
  983. C SI MCOUP=0 DECRIT LA VISIBILITE DU DERNIER COMPOSANT DE MELEME
  984. SEGINI ICPR
  985. DO 3010 I=1,ICPR(/1)
  986. ICPR(I)=0
  987. 3010 CONTINUE
  988. ITE=0
  989. SEGACT MELEME
  990. IPT1=MELEME
  991. DO 3003 I=1,MAX(1,LISOUS(/1))
  992. IF (LISOUS(/1).NE.0) THEN
  993. IPT1=LISOUS(I)
  994. ENDIF
  995. SEGACT IPT1
  996. DO 3005 J=1,IPT1.NUM(/1)
  997. DO 30051 K=1,IPT1.NUM(/2)
  998. IPOIT=IPT1.NUM(J,K)
  999. IF (ICPR(IPOIT).NE.0) GOTO 30051
  1000. ITE=ITE+1
  1001. ICPR(IPOIT)=ITE
  1002. 30051 CONTINUE
  1003. 3005 CONTINUE
  1004. 3003 CONTINUE
  1005. C on complete ICPR avec le 2eme maillage pour que celui ci soit toujours trace
  1006. if (imel2.ne.0) then
  1007. ipt2=melem2
  1008. SEGACT ipt2
  1009. IPT1=ipt2
  1010. DO 3013 I=1,MAX(1,ipt2.LISOUS(/1))
  1011. IF (ipt2.LISOUS(/1).NE.0) THEN
  1012. IPT1=ipt2.LISOUS(I)
  1013. ENDIF
  1014. SEGACT IPT1
  1015. DO 3015 J=1,IPT1.NUM(/1)
  1016. DO 30151 K=1,IPT1.NUM(/2)
  1017. IPOIT=IPT1.NUM(J,K)
  1018. IF (ICPR(IPOIT).NE.0) GOTO 30151
  1019. ITE=ITE+1
  1020. ICPR(IPOIT)=ITE
  1021. 30151 CONTINUE
  1022. 3015 CONTINUE
  1023. 3013 CONTINUE
  1024. endif
  1025. NBCTS=ITE
  1026. DO 5011 I=NBPTS+1,XCOOR(/1)/(IDIM+1)
  1027. IF (ICPR(I).EQ.0) THEN
  1028. ITE=ITE+1
  1029. ICPR(I)=ITE
  1030. ENDIF
  1031. 5011 CONTINUE
  1032. 6010 CONTINUE
  1033. C -FIN DE LA PARTIE SAUTEE SI DEFORMEE OU VECTEURS
  1034. C
  1035. C EN CAS DE TRACE ECLATE ON PROCEDE DIFFEREMMENT
  1036. IF (IECLAT.EQ.1) GOTO 4200
  1037.  
  1038. C ITE EST LE NOMBRE DE POINTS A TRACER ICPR LE TABLEAU
  1039. C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  1040. IMELIN=MELEME
  1041. MCOUIN=MCOUP
  1042.  
  1043. C----------------------------------------------------------
  1044. C LE 2ND MAILLAGE DEVIENT MAILLAGE PRINCIPAL - LES POINTS VUS
  1045. C ONT ETE CALCULES SUR LE 1ER MAILLAGE - (IDEM DEFO)
  1046. C----------------------------------------------------------
  1047. IF (IMEL2.NE.0) THEN
  1048. MELEM3=MELEME
  1049. MELEME=MELEM2
  1050. ENDIF
  1051. IF (IMEL2.NE.0) MCOUP =MCOU2
  1052. IF (IMEL3.NE.0) THEN
  1053. MELEM3=KABEL(IDEF)
  1054. MELEME=KABEL2(IDEF)
  1055. C KABCOR=KABCOR(IDEF)
  1056. ICPR=KABCPR(IDEF)
  1057. C LABCO2=LABCO3
  1058. ENDIF
  1059. IPT1=MELEME
  1060. SEGACT MELEME
  1061.  
  1062. C----------------------------------------------------------
  1063. C REALISATION DU TABLEAU DES CONNECTIONS
  1064. C KON(3,VOISIN,NOEUD) :
  1065. C KON(1,V,N)=Numero DU V-IEME NOEUD RELIE PAR UN SEGMENT AU NOEUD N
  1066. C KON(2,V,N)=COULEUR DU V-IEME NOEUD RELIE PAR UN SEGMENT A N
  1067. C Il peut y avoir plusieurs couleurs collationnees en binaire
  1068. C par ajout de puissances de 2
  1069. C KON(3,V,N)=0 si codage couleur direct, 1 si codage binaire
  1070. C RMQ: SI N=NBCONR, RENVOI SUR LISTE DE NOEUDS VOISINS
  1071. C----------------------------------------------------------
  1072. C Pour permettre les isovaleurss sur les poutres, on exclue de ce tableau
  1073. C ce qui vient des SEG2 et SEG3 si on est en isovaleur
  1074. C
  1075. NBCON =9
  1076. NBCONR=NBCON-1
  1077. NMAX =(12*ITE)/NBCON+200
  1078. SEGINI KON
  1079. C MISE A ZERO DU TABLEAU KON
  1080. DO I=1,NMAX
  1081. DO J=1,NBCON
  1082. KON(1,J,I)=0
  1083. KON(2,J,I)=0
  1084. KON(3,J,I)=0
  1085. ENDDO
  1086. ENDDO
  1087.  
  1088. C FABRICATION DU TABLEAU DES CONNECTIONS
  1089. ICHAIN=ITE
  1090. COUPE=.FALSE.
  1091. C Boucle sur les Partitions
  1092. DO 222 IO=1,MAX(1,LISOUS(/1))
  1093. IF (LISOUS(/1).NE.0) THEN
  1094. COUPE=.FALSE.
  1095. IF (IO.EQ.LISOUS(/1).AND.MCOUP.NE.0) COUPE=.TRUE.
  1096. IPT1=LISOUS(IO)
  1097. ENDIF
  1098. SEGACT IPT1
  1099. K=IPT1.ITYPEL
  1100. C PRISE EN COMPTE DES BLOCAGES
  1101. IF (K.EQ.22) BLOCAG=.TRUE.
  1102. IF (K.EQ.1) CROIX =.TRUE.
  1103. C poutres+iso on saute
  1104. if(iimpi.ge.666) write(ioimp,*)
  1105. & 'avant goto 222 : ICHISO,NISO,MCHPOI=',ICHISO,NISO,MCHPOI
  1106. cbp if ((k.eq.2.or.k.eq.3).and.niso.ne.0.and.
  1107. if ((k.eq.2.or.k.eq.3).and.IISO.NE.0.and.
  1108. > meleme.ne.melem2) goto 222
  1109. C
  1110. if(iimpi.ge.666) write(ioimp,*)
  1111. & 'remplissage de KON depui IPT1=',IPT1
  1112. IDEP=LPT(K)
  1113. IFIN1=IDEP+2*LPL(K)-2
  1114. IFIN2=IFIN1
  1115. IF (LPL(K).EQ.0) THEN
  1116. IF (LPT(K).EQ.0)THEN
  1117. GOTO 2225
  1118. ELSE
  1119. C Polygone
  1120. IFIN1=IDEP+2*IPT1.NUM(/1)-2
  1121. IFIN2=IFIN1 - 2
  1122. ENDIF
  1123. ENDIF
  1124.  
  1125. IF (IDEFOR.NE.0.AND.MDEFOR.NE.0) SEGACT MDEFOR
  1126. C Boucle sur les elements de la partition
  1127. DO 223 I=1,IPT1.NUM(/2)
  1128. IF (IDEFOR.EQ.0.OR.MVECTE.NE.0.OR.IANIM.NE.0) THEN
  1129. KSCOLI=IPT1.ICOLOR(I)
  1130. C IF (KSCOLI.EQ.0) KSCOLI=IDCOUL
  1131. ELSE
  1132. KSCOLI=KSCDEF
  1133. C+PP couleur par defaut pour les deformees = celle du maillage
  1134. IF (KSCOLI.EQ.0) KSCOLI=IPT1.ICOLOR(I)
  1135. C+PP
  1136. C IF (KSCOLI.EQ.0) KSCOLI=IDCOUL
  1137. ENDIF
  1138. if(iimpi.ge.666) write(ioimp,*) 'KSCOLI=',KSCOLI
  1139. IS=1
  1140. DO 2 J=IDEP,IFIN1,2
  1141. IF (J.LE.IFIN2) THEN
  1142. N1=ICPR(IPT1.NUM(KSEGM(J),I))
  1143. N2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  1144. ELSE
  1145. C Polygone
  1146. N1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  1147. N2=ICPR(IPT1.NUM(KSEGM(1),I))
  1148. ENDIF
  1149. IF (COUPE) THEN
  1150. C NE FONCTIONNE QUE SUR DES TRI3
  1151. IS=IS*2
  1152. IF (MOD((2*MCOUP(I))/IS,2).EQ.0) GOTO 2
  1153. ENDIF
  1154. NI=N1
  1155. NJ=N2
  1156. IF (N1*N2.EQ.0) GOTO 8
  1157. C Attribution de la couleur au segment correspondant dans KON :
  1158. IPO=0
  1159. 9 CONTINUE
  1160. KSCOL1=KSCOLI
  1161. NII=NI
  1162. 7 DO 4 K=1,NBCONR
  1163. IF (KON(1,K,NI).GT.NJ) GOTO 4
  1164. IF (KON(1,K,NI).LT.NJ) THEN
  1165. KSAUV1=NJ
  1166. KSCOL1=KSCOLI
  1167. KSCOD1=0
  1168. GOTO 5
  1169. ENDIF
  1170.  
  1171. C recherche si KSCOL1 fait partie des couleurs du segment,
  1172. C si oui (JJ=1), deje traite
  1173. C sinon (JJ=0), on l'ajoute a la liste de couleurs
  1174. C et on met a jour celle des segments eventuellement confondus
  1175. JJ=0
  1176. C IF (KSCOL1.EQ.0) KSCOL1=IDCOUL
  1177. CPM IF (KON(2,K,NI).LT.300) KON(2,K,NI)=
  1178. CPM $ 300+(2**(KON(2,K,NI)-1))
  1179. IF (KON(3,K,NI).EQ.0) THEN
  1180. C Passage en binaire si pas deja fait
  1181. KON(3,K,NI)=1
  1182. IK=KON(2,K,NI)
  1183. KON(2,K,NI)=IPUIS2(IK)
  1184. C Il n'y a qu'une seule couleur de codee, facile a tester
  1185. IF (IK.EQ.KSCOL1) JJ=1
  1186. ELSE
  1187. C potentiellement plusieurs couleurs codees, a tester
  1188. CPM ICAL=KON(2,K,NI)-300
  1189. ICAL=KON(2,K,NI)
  1190. CPM (NBCOUL-1) au lieu de 7
  1191. DO II=(NBCOUL-1),KSCOL1,-1
  1192. IF (IPUIS2(II).LE.ICAL) THEN
  1193. IF (II.EQ.KSCOL1) THEN
  1194. JJ=1
  1195. ELSE
  1196. ICAL=ICAL-IPUIS2(II)
  1197. ENDIF
  1198. ENDIF
  1199. ENDDO
  1200. ENDIF
  1201.  
  1202. C Si cette couleur existe, le segment a deja ete traite
  1203. IF (JJ.EQ.1) GOTO 2
  1204.  
  1205. C sinon on ajoute la couleur a la liste binaire de couleurs du segment
  1206. KON(2,K,NI)=KON(2,K,NI)+IPUIS2(KSCOL1)
  1207.  
  1208. C ainsi qu'aux segments confondus eventuels
  1209. 1111 CONTINUE
  1210. DO II=1,NBCONR
  1211. IF (KON(1,II,NJ).EQ.NII) THEN
  1212. KON(2,II,NJ)=KON(2,K,NI)
  1213. KON(3,II,NJ)=KON(3,K,NI)
  1214. GOTO 1113
  1215. ENDIF
  1216. ENDDO
  1217. IF (KON(1,NBCON,NJ).NE.0) THEN
  1218. NJ=KON(1,NBCON,NJ)
  1219. GOTO 1111
  1220. ENDIF
  1221. 1113 CONTINUE
  1222. GOTO 2
  1223. 4 CONTINUE
  1224.  
  1225. C on passe au noeud suivant dans la chaine,
  1226. C ou on l'incremente et on la met a jour si on est arrive au bout
  1227. IF (KON(1,NBCON,NI).NE.0) THEN
  1228. NI=KON(1,NBCON,NI)
  1229. GOTO 7
  1230. ENDIF
  1231. KSAUV1=NJ
  1232. KSCOL1=KSCOLI
  1233. KSCOD1=1
  1234. 301 ICHAIN=ICHAIN+1
  1235. IF (ICHAIN.EQ.NMAX) THEN
  1236. NMAX=NMAX+1000
  1237. SEGADJ KON
  1238. C WRITE (IOIMP,*) 'PRTRAC: KON agrandi'
  1239. ENDIF
  1240. KON(1,NBCON,NI)=ICHAIN
  1241. K=1
  1242. NI=ICHAIN
  1243.  
  1244. C On insere la nouvelle connexion NJ a la place de la
  1245. C connexion actuelle, et on decale le reste d'un cran
  1246. 5 CONTINUE
  1247. KSAUV=KON(1,K,NI)
  1248. KSCOL=KON(2,K,NI)
  1249. KSCOD=KON(3,K,NI)
  1250. C IF (KSCOL1.EQ.0) KSCOL1=IDCOUL
  1251. KON(1,K,NI)=KSAUV1
  1252. KON(2,K,NI)=KSCOL1
  1253. KON(3,K,NI)=KSCOD1
  1254. KSAUV1=KSAUV
  1255. KSCOL1=KSCOL
  1256. KSCOD1=KSCOD
  1257. IF (KSAUV.EQ.0) GOTO 3
  1258. KDEP=K+1
  1259. IF (KDEP.EQ.NBCON) GOTO 302
  1260. 303 CONTINUE
  1261. DO KHE=KDEP,NBCONR
  1262. KSAUV=KON(1,KHE,NI)
  1263. KSCOL=KON(2,KHE,NI)
  1264. KSCOD=KON(3,KHE,NI)
  1265. C IF (KSCOL1.EQ.0) KSCOL1=IDCOUL
  1266. KON(1,KHE,NI)=KSAUV1
  1267. KON(2,KHE,NI)=KSCOL1
  1268. KON(3,KHE,NI)=KSCOD1
  1269. IF (KSAUV.EQ.0) GOTO 3
  1270. KSAUV1=KSAUV
  1271. KSCOL1=KSCOL
  1272. KSCOD1=KSCOD
  1273. ENDDO
  1274. 302 CONTINUE
  1275. IF (KON(1,NBCON,NI).EQ.0) GOTO 301
  1276. NI=KON(1,NBCON,NI)
  1277. KDEP=1
  1278. GOTO 303
  1279. 3 IF (NJ.NE.N2.OR.IPO.EQ.1) GOTO 2
  1280. NI=N2
  1281. NJ=N1
  1282. IPO=1
  1283. GOTO 9
  1284. 2 CONTINUE
  1285. 223 CONTINUE
  1286. 2225 CONTINUE
  1287. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1288. 222 CONTINUE
  1289. GOTO 10
  1290. C Operation malvenue. Resultat douteux
  1291. 8 CALL ERREUR(23)
  1292.  
  1293. 10 CONTINUE
  1294.  
  1295. SEGDES MELEME
  1296. CTC IF (MCOU2.NE.0) THEN
  1297. C NETTOYAGE APRES COUPE
  1298. C SEGSUP MCOUP
  1299. C SEGACT MELEME
  1300. C DO 8802 IO=1,LISOUS(/1)
  1301. C IPT1=LISOUS(IO)
  1302. C SEGSUP IPT1
  1303. C 8802 CONTINUE
  1304. C SEGSUP MELEME
  1305. C ENDIF
  1306. MELEME=IMELIN
  1307. MCOUP =MCOUIN
  1308. C GESTION DU TABLEAU ICPR(COMPTEUR DE COULEUR)
  1309. C ITEST(II) = 1 si la couleur appartient a la liste du point, 0 sinon
  1310. C (= conversion de KON(2,I,J) en tableau)
  1311. C ICHC(I) : nb de segments sur lesquels apparait la couleur I
  1312. C On ramene, si code en binaire, KON(2,.,.) dans l'intervalle
  1313. C [0;NBCOUL-1] en melangeant eventuellement les couleurs des
  1314. C segments confondus
  1315. DO 310 I=1,NBCONR
  1316. DO 3101 J=1,KON(/3)
  1317. CPM on ecrit IK au lieu de KON(2,I,J) pour economiser l'acces memoire
  1318. IK=KON(2,I,J)
  1319. IF (IK.NE.0) THEN
  1320. CPM IF (IK.LE.9) THEN
  1321. IF (KON(3,I,J).EQ.0) THEN
  1322. C KON(2,.,.) est deja code dans l'intervalle [0;NBCOUL-1]
  1323. C soit que ce segment est seul, soit qu'il a deja ete rencontre 1 fois
  1324. ICHC(IK)=ICHC(IK)+1
  1325. ELSE
  1326. C cas ou KON est code en puissances de 2 dans [1;2**(NBCOUL-1)]
  1327. CPM NBCOUL-1 au lieu de 7
  1328. C tablage des couleurs possibles. IK finit a 0
  1329. DO II=1,(NBCOUL-1)
  1330. ITEST(II)=0
  1331. ENDDO
  1332. CPM NBCOUL-1 au lieu de 7
  1333. DO II=(NBCOUL-1),1,-1
  1334. IF (IPUIS2(II).LE.IK) THEN
  1335. IK=IK-IPUIS2(II)
  1336. ITEST(II)=1
  1337. ENDIF
  1338. ENDDO
  1339.  
  1340. C Couleur finale du segment a tracer
  1341. IF (IDEFCO.EQ.1.AND.ITEST(IICOL).EQ.1) THEN
  1342. C Le segment est eligible
  1343. IK=IICOL
  1344. ELSE
  1345. CPM NBCOUL-1 au lieu de 7
  1346. IK=0
  1347. DO II=1,NBCOUL-1
  1348. IF (ITEST(II).EQ.1) THEN
  1349. C si plusieurs couleurs, on les melange
  1350. IF (IK.EQ.0) THEN
  1351. IK=II
  1352. ELSE
  1353. IK=ITABM(IK,II)
  1354. ENDIF
  1355. ENDIF
  1356. ENDDO
  1357. ENDIF
  1358. KON(2,I,J)=IK
  1359. KON(3,I,J)=0
  1360. ICHC(IK)=ICHC(IK)+1
  1361. ENDIF
  1362. ENDIF
  1363. 3101 CONTINUE
  1364. 310 CONTINUE
  1365. SEGDES KON
  1366. IF (IRESU.EQ.6) GOTO 4999
  1367.  
  1368. C POINT D'ARRIVEE SI ECLATE
  1369. 4200 CONTINUE
  1370. segact icpr
  1371. SEGINI XPROJ
  1372. IF (IDEFOR.NE.0) GOTO 6030
  1373. C IF (IDEFOR.NE.0.OR.MVECTE.NE.0) GOTO 6030 A VOIR PV
  1374. C LA TROISIEME COORDONNEE PROJETEE EST LA DISTANCE A L'OEIL
  1375. CALL PROJEC(ICPR,XPROJ,IOEIL,CGRAV,axez)
  1376. SEGDES ICPR
  1377. IF (ZBOIT) THEN
  1378. CALL PROJC2(IMBOIT,IOEIL,CGRAV,XBMIN,XBMAX,YBMIN
  1379. $ ,YBMAX,ZBMIN,ZBMAX)
  1380. ENDIF
  1381. C
  1382. XMIN=1E30
  1383. XMAX=-XMIN
  1384. YMIN=XMIN
  1385. YMAX=XMAX
  1386. ZMIN=XMIN
  1387. ZMAX=XMAX
  1388. DO I=1,ITE
  1389. XMIN=MIN(XMIN,XPROJ(1,I))
  1390. XMAX=MAX(XMAX,XPROJ(1,I))
  1391. YMIN=MIN(YMIN,XPROJ(2,I))
  1392. YMAX=MAX(YMAX,XPROJ(2,I))
  1393. ZMIN=MIN(ZMIN,XPROJ(3,I))
  1394. ZMAX=MAX(ZMAX,XPROJ(3,I))
  1395. ENDDO
  1396. C
  1397. XDEC=XMAX-XMIN
  1398. YDEC=YMAX-YMIN
  1399. ZDEC=ZMAX-ZMIN
  1400. C Modif des marges
  1401. C Nouveau :
  1402. DDEC=MAX(XDEC,YDEC,ZDEC)*0.1
  1403. C MODIF JCARDO 28/02/2012 : DDEC vaut maintenant XSZPRE au minimum
  1404. C (evite des erreurs de cancellation)
  1405. DDEC=MAX(DDEC,REAL(xszpre))
  1406. C DDEC=MAX(DDEC,xspeti)
  1407. XMAX=XMAX+DDEC
  1408. XMIN=XMIN-DDEC
  1409. YMIN=YMIN-DDEC
  1410. YMAX=YMAX+DDEC
  1411. ZMIN=ZMIN-DDEC
  1412. ZMAX=ZMAX+DDEC
  1413. C Zoom ou dezoome
  1414. IF (ZBOIT) THEN
  1415. XMI=XBMIN
  1416. XMA=XBMAX
  1417. YMI=YBMIN
  1418. YMA=YBMAX
  1419. ZMI=ZBMIN
  1420. ZMA=ZBMAX
  1421. ELSE
  1422. XMI=XMIN
  1423. YMI=YMIN
  1424. ZMI=ZMIN
  1425. XMA=XMAX
  1426. YMA=YMAX
  1427. ZMA=ZMAX
  1428. ENDIF
  1429. Cgoo CALL DFENET(XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,X1,X2,Y1,Y2,FENET)
  1430. CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET)
  1431. GOTO 6040
  1432. 6030 CONTINUE
  1433. C FAIRE ICI LA PROJECTION DE LA DEFORMEE
  1434. C PP + option DIRE
  1435. CALL CADRCL(KABCOR,LABCO2,IOEIL,XPROJ,
  1436. * IDEF,XMIN,YMIN,XMAX,YMAX,ZMIN,ZMAX,cgrav,diloc,ldire,axez)
  1437. 6040 CONTINUE
  1438. C
  1439. C
  1440. C BERTIN: AFFICHAGE DE LA DATE
  1441. IF (ZDATE) THEN
  1442. CALL GIBDAT(JOUR,MOIS,IANNEE)
  1443. iannee=mod(iannee,100)
  1444. C*TC TIME=FDATE()
  1445. BUFFER(1:22)=' / /20 '
  1446. WRITE (BUFFER(4:5),FMT='(I2)') JOUR
  1447. WRITE (BUFFER(7:8),FMT='(I2)') MOIS
  1448. WRITE (BUFFER(12:13),FMT='(I2)') IANNEE
  1449. C*TC WRITE (BUFFER(15:22),FMT='(A8)') TIME(12:20)
  1450. C CALL TRBOX(0.8,0.8)
  1451. READ(BUFFER(1:22),'(A26)') BUFFER
  1452. C CALL TRBOX(1./0.8,1./0.8)
  1453. ENDIF
  1454. C BERTIN: FIN AFFICHAGE DE LA DATE
  1455.  
  1456. C----------------------------------------------------------
  1457. C INITIALISATION DE IVU SI NON FAIT
  1458. C IVU=1 PT VU
  1459. C IVU<>1 PT PAS VU
  1460. C----------------------------------------------------------
  1461. 4999 CONTINUE
  1462. IF (IVU.EQ.0) THEN
  1463. SEGINI IVU
  1464. DO 4997 I=1,ITE
  1465. IVU(I)=1
  1466. 4997 CONTINUE
  1467. ENDIF
  1468. C METTRE NON CACHABLE LES POINTS DU PLAN DE COUPE
  1469. SEGADJ IVU
  1470. C IF (ICACHE.NE.0.AND.NBCTS.NE.0) THEN CORRECTION PV
  1471. IF (NBCTS.NE.0) THEN
  1472. DO 5010 I=NBCTS+1,ITE
  1473. IVU(I)=2
  1474. 5010 CONTINUE
  1475. ENDIF
  1476. C
  1477. CPM NBCOUL-1 au lieu de 8
  1478. DO I=1,NBCOUL-1
  1479. ICHCS(I)=ICHC(I)
  1480. ENDDO
  1481. C cacher en soft si pas opengl
  1482. if (iogra.ne.6) then
  1483. C DEBUT MODIF
  1484. IF (ICACHE.NE.0) THEN
  1485. IF (IARET.EQ.0) THEN
  1486. CALL TIRET3(XPROJ,MELEME,ICPR,XMIN,XMAX,YMIN,YMAX,
  1487. . IVU,NELEM,TMIN,TMAX,MCOUP)
  1488. ELSE
  1489.  
  1490. CALL TIRET3(XPROJ,MELEM3,ICPR,XMIN,XMAX,YMIN,YMAX,
  1491. . IVU,NELEM,TMI,TMAX,MCOUP)
  1492. ENDIF
  1493. ENDIF
  1494. C FIN MODIF
  1495. endif
  1496.  
  1497. C------------------------------------------------------------
  1498. C CAS DU TRACE PAR FACE APPEL AU SOUS-PROGRAM FACED
  1499. C POUR REMPLIR LES FACES
  1500. C------------------------------------------------------------
  1501. IF (IECLAT.NE.1) THEN
  1502. if(iimpi.ge.666) then
  1503. segact,KON
  1504. write(ioimp,*) 'KON(1,:,1)=',(KON(1,iou,1),iou=1,3)
  1505. write(ioimp,*) 'KON(2,:,1)=',(KON(2,iou,1),iou=1,3)
  1506. write(ioimp,*) 'KON(3,:,1)=',(KON(3,iou,1),iou=1,3)
  1507. write(ioimp,*) 'KON(1,:,2)=',(KON(1,iou,2),iou=1,3)
  1508. write(ioimp,*) 'KON(2,:,2)=',(KON(2,iou,2),iou=1,3)
  1509. write(ioimp,*) 'KON(3,:,2)=',(KON(3,iou,2),iou=1,3)
  1510. write(ioimp,*) 'KON(1,:,3)=',(KON(1,iou,3),iou=1,3)
  1511. write(ioimp,*) 'KON(2,:,3)=',(KON(2,iou,3),iou=1,3)
  1512. write(ioimp,*) 'KON(3,:,3)=',(KON(3,iou,3),iou=1,3)
  1513. endif
  1514. if(iimpi.ge.666) write(ioimp,*) 'appel a FACED',IFADES
  1515. IF (IFADES.EQ.1) THEN
  1516. CALL FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,1)
  1517. ELSEIF (IFADES.EQ.0.AND.IOGRA.EQ.6.AND.ICACHE.EQ.1) THEN
  1518. C TRACe DES ELEMENTS EN EFFACEMENT
  1519. CALL FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,0)
  1520. ENDIF
  1521. ENDIF
  1522. IF (IERR.NE.0) GOTO 8900
  1523.  
  1524. C------------------------------------------------------------
  1525. C
  1526. C CAS OU ON VEUT TRACER LES ISOVALEURS D UN OBJET DE TYPE CHAMPOINT
  1527. C
  1528. C------------------------------------------------------------
  1529. cbp IF (NISO.NE.0) THEN
  1530. IF (VCPCHA.NE.0) THEN
  1531. C signaler le nombre d'iso
  1532. CALL FVALIS(0,IRESU,NHAUT,NISO)
  1533. PTI=XMAX-XMIN
  1534. if(iimpi.ge.666) write(ioimp,*) 'apel a ATISO'
  1535. CALL ATISO(MELEME,ICPR,XPROJ,VCPCHA,VCHC,IVU,PTI,NISO,MCOUP,
  1536. > mcham)
  1537. ENDIF
  1538. C
  1539. C 6080 CONTINUE
  1540. IF (IERR.NE.0) RETURN
  1541. IF (ICACHE.EQ.1) THEN
  1542. LTSEGS=1000
  1543. SEGINI NTSEG
  1544. LTSEG=0
  1545. endif
  1546. C 5001 CONTINUE
  1547. C IF (IECLAT.EQ.1.OR.IFADES.EQ.1) GOTO 4201 PV JUIN 86
  1548. IF (IECLAT.EQ.1) GOTO 4201
  1549. C TRACE DES SEGMENTS D'UNE COULEUR EN LES GROUPANT EN UNE LIGNE
  1550. if(iimpi.ge.666) write(ioimp,*) 'TRACE DES SEGMENTS DUNE COULEUR'
  1551. SEGACT KON*MOD
  1552. C PM NBCOUL-1 au lieu de 8
  1553. icoul=-3
  1554. DO 70 LI=0,NBCOUL-1
  1555. IF (IDEFCO.EQ.1 .AND. LI.NE.IICOL) GOTO 70
  1556. C SI ISOVALEUR ET REMPLISSAGE COULEUR EFFACEMENT
  1557. C MODIF JCARDO 8/12/2011 : rajout condition LI=0
  1558. C => on force NOIR seulement si COUL=DEFA
  1559. C MODIF JCARDO 28/02/2012 : rajout condition IMEL2=0 (eventuellement)
  1560. C => on force NOIR seulement s'il y a un
  1561. C seul objet MAILLAGE
  1562. C IF (NISO.NE.0.AND.ISOTYP.GT.0) CALL CHCOUL(IDNOIR)
  1563. C IF (LI.EQ.0.AND.NISO.NE.0.AND.ISOTYP.GT.0)
  1564. cbp IF ((IMEL2.EQ.0.OR.LI.EQ.0).AND.NISO.NE.0.AND.ISOTYP.GT.0)
  1565. IF ((IMEL2.EQ.0.OR.LI.EQ.0).AND.IISO.NE.0.AND.ISOTYP.GT.0) then
  1566. kcoul=idnoir
  1567. ELSE
  1568. C PP kcoul=LI
  1569. C+PP FACE avec trait blanc
  1570. IF (LBLANC) THEN
  1571. kcoul=0
  1572. ELSE
  1573. kcoul=LI
  1574. ENDIF
  1575. C+PP
  1576. ENDIF
  1577. KAUX=1
  1578. 23 K=KAUX
  1579. IF (IVU(KAUX).LE.0) GOTO 40
  1580. KAUXR=KAUX
  1581. 41 CONTINUE
  1582. DO 19 KL=1,NBCONR
  1583. ITRA=KON(1,KL,K)
  1584. IF (ITRA.LT.0) GOTO 19
  1585. IF (ITRA.EQ.0) GOTO 40
  1586. IF (KON(2,KL,K).NE.LI) GOTO 19
  1587. IF (IVU(ITRA).GE.1) GOTO 21
  1588. 19 CONTINUE
  1589. K=KON(1,NBCON,K)
  1590. IF (K.NE.0) GOTO 41
  1591. 40 KAUX=KAUX+1
  1592. IF (KAUX.GE.ITE+1) GOTO 27
  1593. GOTO 23
  1594. 21 CONTINUE
  1595. IF (ITR.GT.1) THEN
  1596. if (kcoul.ne.icoul) then
  1597. call chcoul(kcoul)
  1598. icoul=kcoul
  1599. endif
  1600. CALL POLRL(ITR,XTR,YTR,ZTR)
  1601. ENDIF
  1602. ITR=1
  1603. XTR(ITR)=XPROJ(1,KAUXR)
  1604. YTR(ITR)=XPROJ(2,KAUXR)
  1605. ZTR(ITR)=XPROJ(3,KAUXR)
  1606. KPRESS=KAUXR
  1607. GOTO 25
  1608. 24 KL=1
  1609. 25 DO 22 L=KL,NBCONR
  1610. M=KON(1,L,K)
  1611. IF (M.EQ.0) GOTO 23
  1612. IF (M.LT.0) GOTO 22
  1613. IF (KON(2,L,K).NE.LI) GOTO 22
  1614. IF (IVU(M).LE.0) GOTO 22
  1615. GOTO 28
  1616. 22 CONTINUE
  1617. K=KON(1,NBCON,K)
  1618. IF (K.EQ.0) GOTO 23
  1619. GOTO 24
  1620. 28 CONTINUE
  1621. ITR=ITR+1
  1622. XTR(ITR)=XPROJ(1,M)
  1623. YTR(ITR)=XPROJ(2,M)
  1624. ZTR(ITR)=XPROJ(3,M)
  1625. IF (ITR.EQ.40) THEN
  1626. if (kcoul.ne.icoul) then
  1627. call chcoul(kcoul)
  1628. icoul=kcoul
  1629. endif
  1630. CALL POLRL(ITR,XTR,YTR,ZTR)
  1631. XTR(1)=XTR(ITR)
  1632. YTR(1)=YTR(ITR)
  1633. ZTR(1)=ZTR(ITR)
  1634. ITR=1
  1635. ENDIF
  1636. KON(1,L,K)=-KON(1,L,K)
  1637. M1=M
  1638. 42 DO 43 L=1,NBCONR
  1639. IF (KON(1,L,M1).EQ.0) GOTO 45
  1640. IF (KON(1,L,M1).EQ.KPRESS) GOTO 44
  1641. 43 CONTINUE
  1642. M1=KON(1,NBCON,M1)
  1643. IF (M1.EQ.0) GOTO 45
  1644. GOTO 42
  1645. 44 KON(1,L,M1)=-KON(1,L,M1)
  1646. 45 KPRESS=M
  1647. GOTO 24
  1648. 27 CONTINUE
  1649. IF (ITR.NE.1) THEN
  1650. if (kcoul.ne.icoul) then
  1651. call chcoul(kcoul)
  1652. icoul=kcoul
  1653. endif
  1654. CALL POLRL(ITR,XTR,YTR,ZTR)
  1655. ENDIF
  1656. ITR=0
  1657. 70 CONTINUE
  1658. IF (ICACHE.EQ.0) GOTO 5002
  1659.  
  1660. C----------------------------------------------------------
  1661. C ON REMPLIT NTSEG AVEC LES SEGMENTS EN PARTIE VUS
  1662. C (OPTION CACHE)
  1663. C----------------------------------------------------------
  1664. DO 5003 K=1,ITE
  1665. IF (IVU(K).LE.0) GOTO 5003
  1666. KK=K
  1667. 5005 CONTINUE
  1668. DO 5004 KL=1,NBCONR
  1669. ITRA=KON(1,KL,KK)
  1670. IF (ITRA.LT.0) GOTO 5004
  1671. IF (ITRA.EQ.0) GOTO 5003
  1672. IF (LTSEGS-LTSEG.LT.10) THEN
  1673. LTSEGS=LTSEGS+1000
  1674. SEGADJ NTSEG
  1675. ENDIF
  1676. NTSEG(LTSEG+1)=K
  1677. NTSEG(LTSEG+2)=ITRA
  1678. C MODIF JCARDO 28/02/2012 : rajout conditions LICLR=0 (+ eventuellement IMEL2=0)
  1679. C cf. commentaires 100 lignes plus haut...
  1680. C IF (NISO.NE.0.AND.ISOTYP.GT.0) THEN
  1681. LICLR=KON(2,KL,KK)
  1682. C IF (LICLR.EQ.0.AND.NISO.NE.0.AND.ISOTYP.GT.0) THEN
  1683. IF ((IMEL2.EQ.0.OR.LICLR.EQ.0)
  1684. cbp & .AND.NISO.NE.0.AND.ISOTYP.GT.0) THEN
  1685. & .AND.IISO.NE.0.AND.ISOTYP.GT.0) THEN
  1686. CPM IDNOIR au lieu de 8
  1687. NTSEG(LTSEG+3)=IDNOIR
  1688. ELSE
  1689. NTSEG(LTSEG+3)=LICLR
  1690. ENDIF
  1691. LTSEG=LTSEG+3
  1692. 5004 CONTINUE
  1693. KK=KON(1,NBCON,KK)
  1694. IF (KK.NE.0) GOTO 5005
  1695. 5003 CONTINUE
  1696. 5002 CONTINUE
  1697. SEGDES KON
  1698. C Trace des petites croix, cas de type POI1
  1699. IF (CROIX) then
  1700. C CALCUL TAILLE POUR LES CROIX
  1701. XDIB=XMAX-XMIN
  1702. YDIB=YMAX-YMIN
  1703. BLOK=MAX(XDIB,YDIB)*0.003
  1704. IPT1=MELEME
  1705. IF (IMEL2.NE.0) IPT1=MELEM2
  1706. SEGACT IPT1
  1707. SEGACT MELEME
  1708. DO 8002 ISOUS=1,MAX(1,LISOUS(/1))
  1709. IF (LISOUS(/1).NE.0) THEN
  1710. IPT1=LISOUS(ISOUS)
  1711. SEGACT IPT1
  1712. ENDIF
  1713. IF (IPT1.ITYPEL.NE.1) GOTO 8004
  1714. C----------------------------------------------------------
  1715. C TRACE DES croix
  1716. C----------------------------------------------------------
  1717. SEGACT IVU,ICPR
  1718. icc = -3
  1719. NBNN=IPT1.NUM(/1)
  1720. DO 8005 IEL=1,IPT1.NUM(/2)
  1721. IF (IVU(ICPR(IPT1.NUM(1,IEL))).GE.1) THEN
  1722. ICOOL=IPT1.ICOLOR(IEL)
  1723. C IF (ICOOL.LE.0) ICOOL=IDCOUL
  1724. CPM IDNOIR au lieu de 8
  1725. cbp IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1726. IF (IISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1727. IF (ICOOL.NE.ICC) THEN
  1728. ICC=ICOOL
  1729. CALL CHCOUL(ICC)
  1730. ENDIF
  1731. XPOS=XPROJ(1,ICPR(IPT1.NUM(1,IEL)))
  1732. YPOS=XPROJ(2,ICPR(IPT1.NUM(1,IEL)))
  1733. ZPOS=XPROJ(3,ICPR(IPT1.NUM(1,IEL)))
  1734. XTR(1)=XPOS+BLOK
  1735. YTR(1)=YPOS
  1736. ZTR(1)=ZPOS
  1737. XTR(2)=XPOS-BLOK
  1738. YTR(2)=YPOS
  1739. ZTR(2)=ZPOS
  1740. CALL POLRL(2,XTR,YTR,ZTR)
  1741. XTR(1)=XPOS
  1742. YTR(1)=YPOS+BLOK
  1743. ZTR(1)=ZPOS
  1744. XTR(2)=XPOS
  1745. YTR(2)=YPOS-BLOK
  1746. ZTR(2)=ZPOS
  1747. CALL POLRL(2,XTR,YTR,ZTR)
  1748. ENDIF
  1749. 8005 CONTINUE
  1750. 8004 CONTINUE
  1751. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1752. 8002 CONTINUE
  1753. SEGDES MELEME
  1754. endif
  1755. C Y A T IL DES BLOCAGES ???
  1756. IF (.NOT.BLOCAG) GOTO 7000
  1757. C CALCUL TAILLE POUR LES BLOCAGES
  1758. XDIB=XMAX-XMIN
  1759. YDIB=YMAX-YMIN
  1760. BLOK=MAX(XDIB,YDIB)*0.01
  1761. ICC=-3
  1762. SEGACT MELEME
  1763. IPT1=MELEME
  1764. DO 7002 ISOUS=1,MAX(1,LISOUS(/1))
  1765. IF (LISOUS(/1).NE.0) THEN
  1766. IPT1=LISOUS(ISOUS)
  1767. SEGACT IPT1
  1768. ENDIF
  1769. IF (IPT1.ITYPEL.NE.22) GOTO 7004
  1770. C----------------------------------------------------------
  1771. C TRACE DES BLOCAGES
  1772. C----------------------------------------------------------
  1773. SEGACT IVU,ICPR
  1774. NBNN=IPT1.NUM(/1)
  1775. DO 7005 IEL=1,IPT1.NUM(/2)
  1776. ICOOL=IPT1.ICOLOR(IEL)
  1777. C IF (ICOOL.LE.0) ICOOL=IDCOUL
  1778. IF (NBNN.GT.2) THEN
  1779. C IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1780. IF (ICOOL.NE.ICC) THEN
  1781. ICC=ICOOL
  1782. CALL CHCOUL(ICC)
  1783. ENDIF
  1784. JDTRAC=0
  1785. DO 7006 INO=2,NBNN
  1786. INOS=INO+1
  1787. IF (INOS.GT.NBNN) INOS = 2
  1788. IP1=ICPR(IPT1.NUM(INO,IEL))
  1789. IP2=ICPR(IPT1.NUM(INOS,IEL))
  1790. IF (IVU(IP1).GE.1.AND.IVU(IP2).GE.1) THEN
  1791. IF (JDTRAC.EQ.0) THEN
  1792. XTR(1)=XPROJ(1,IP1)
  1793. YTR(1)=XPROJ(2,IP1)
  1794. ZTR(1)=XPROJ(3,IP1)
  1795. XTR(2)=XPROJ(1,IP2)
  1796. YTR(2)=XPROJ(2,IP2)
  1797. ZTR(2)=XPROJ(3,IP2)
  1798. CALL POLRL(2,XTR,YTR,ZTR)
  1799. ENDIF
  1800. JDTRAC=1
  1801. ELSEIF (IVU(IP1).GE.1) THEN
  1802. IF (LTSEGS-LTSEG.LT.10) THEN
  1803. LTSEGS=LTSEGS+1000
  1804. SEGADJ NTSEG
  1805. ENDIF
  1806. NTSEG(LTSEG+1)=IP1
  1807. NTSEG(LTSEG+2)=IP2
  1808. NTSEG(LTSEG+3)=ICC
  1809. LTSEG=LTSEG+3
  1810. JDTRAC=0
  1811. ELSEIF (IVU(IP2).GE.1) THEN
  1812. IF (LTSEGS-LTSEG.LT.10) THEN
  1813. LTSEGS=LTSEGS+1000
  1814. SEGADJ NTSEG
  1815. ENDIF
  1816. NTSEG(LTSEG+1)=IP2
  1817. NTSEG(LTSEG+2)=IP1
  1818. NTSEG(LTSEG+3)=ICC
  1819. LTSEG=LTSEG+3
  1820. JDTRAC=0
  1821. ENDIF
  1822. 7006 CONTINUE
  1823. ELSEIF (NBNN.EQ.2.AND.IVU(ICPR(IPT1.NUM(2,IEL))).GE.1) THEN
  1824. cbp IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1825. IF (IISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1826. IF (ICOOL.NE.ICC) THEN
  1827. ICC=ICOOL
  1828. CALL CHCOUL(ICC)
  1829. ENDIF
  1830. XPOS=XPROJ(1,ICPR(IPT1.NUM(2,IEL)))
  1831. YPOS=XPROJ(2,ICPR(IPT1.NUM(2,IEL)))
  1832. ZPOS=XPROJ(3,ICPR(IPT1.NUM(2,IEL)))
  1833. XTR(1)=XPOS+BLOK
  1834. YTR(1)=YPOS
  1835. ZTR(1)=ZPOS
  1836. XTR(2)=XPOS
  1837. YTR(2)=YPOS+BLOK
  1838. ZTR(2)=ZPOS
  1839. XTR(3)=XPOS-BLOK
  1840. YTR(3)=YPOS
  1841. ZTR(3)=ZPOS
  1842. XTR(4)=XPOS
  1843. YTR(4)=YPOS-BLOK
  1844. ZTR(4)=ZPOS
  1845. XTR(5)=XTR(1)
  1846. YTR(5)=YTR(1)
  1847. ZTR(5)=ZTR(1)
  1848. CALL POLRL(5,XTR,YTR,ZTR)
  1849. ENDIF
  1850. 7005 CONTINUE
  1851. 7004 CONTINUE
  1852. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1853. 7002 CONTINUE
  1854. SEGDES MELEME
  1855. 7000 CONTINUE
  1856. if (iogra.eq.6) goto 4202
  1857. IF (ICACHE.NE.0) THEN
  1858. C PP FACE avec trait blanc
  1859. CALL DICHO3(XPROJ,MELEME,ICPR,XMIN,XMAX,
  1860. * YMIN,YMAX,IVU,NTSEG,NELEM,IICOL,IDEFCO,lblanc,LTSEG)
  1861. C PP * YMIN,YMAX,IVU,NTSEG,NELEM,IICOL,IDEFCO)
  1862. ENDIF
  1863. GOTO 4202
  1864. 4201 CONTINUE
  1865. C----------------------------------------------------------
  1866. C
  1867. C TRACE ECLATE DES ELEMENTS
  1868. C
  1869. C----------------------------------------------------------
  1870. SEGACT ICPR
  1871. C IF (IFADES.EQ.1) GOTO 4400 PV JUIN 86
  1872. SEGACT MELEME
  1873. ICOLE=0
  1874. IPT1=MELEME
  1875. DO 4111 IO=1,MAX(1,LISOUS(/1))
  1876. IF (LISOUS(/1).NE.0) THEN
  1877. IPT1=LISOUS(IO)
  1878. SEGACT IPT1
  1879. ENDIF
  1880. K=IPT1.ITYPEL
  1881. IDEP=LPT(K)
  1882. IFIN=IDEP+2*LPL(K)-2
  1883. IFIN2=IFIN
  1884. IF (LPL(K).EQ.0) THEN
  1885. IF (LPT(K).EQ.0)THEN
  1886. GOTO 4112
  1887. ELSE
  1888. C Polygone
  1889. IFIN=IDEP+2*IPT1.NUM(/1)-2
  1890. IFIN2=IFIN -2
  1891. ENDIF
  1892. ENDIF
  1893. 4112 CONTINUE
  1894. C IFIN=IDEP+2*LPL(K)-2
  1895. DO 4115 I=1,IPT1.NUM(/2)
  1896. IF (IDEFCO.EQ.1.AND.IPT1.ICOLOR(I).NE.IICOL) GOTO 4115
  1897. XG=0.
  1898. YG=0.
  1899. ZG=0.
  1900. ZN=0.
  1901. N=IPT1.NUM(/1)
  1902. DO 4116 J=1,N
  1903. XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
  1904. YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
  1905. ZG=ZG+XPROJ(3,ICPR(IPT1.NUM(J,I)))
  1906. 4116 CONTINUE
  1907. XG=XG/N
  1908. YG=YG/N
  1909. ZG=ZG/N
  1910. I3=0
  1911. IF (ICOLE.NE.IPT1.ICOLOR(I)) THEN
  1912. ICOLE=IPT1.ICOLOR(I)
  1913. CALL CHCOUL(ICOLE)
  1914. ENDIF
  1915. ITR=1
  1916. ILTEL=LTEL(1,K)
  1917. IF (ILTEL.NE.0) THEN
  1918. DO 4117 IF=1,ILTEL
  1919. ITR=0
  1920. ILTAD=LTEL(2,K)
  1921. ITYP=LDEL(1,ILTAD+IF-1)
  1922. IAD=LDEL(2,ILTAD+IF-1)
  1923. DO 4118 J=1,KDFAC(1,ITYP)
  1924. I1=ICPR(IPT1.NUM(LFAC(IAD+J-1),I))
  1925. XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  1926. YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  1927. ZR=ZG+(XPROJ(3,I1)-ZG)*XECLAT
  1928. ITR=ITR+1
  1929. XTR(ITR)=XR
  1930. YTR(ITR)=YR
  1931. ZTR(ITR)=ZR
  1932. 4118 CONTINUE
  1933. ITR=ITR+1
  1934. XTR(ITR)=XTR(1)
  1935. YTR(ITR)=YTR(1)
  1936. ZTR(ITR)=ZTR(1)
  1937. IF (IFADES.EQ.0) THEN
  1938. CALL POLRL(ITR,XTR,YTR,ZTR)
  1939. ELSE
  1940. CALL TRFACE(ITR,XTR,YTR,ZTR,ZN,ICOLE,IEFF)
  1941. CALL CHCOUL(IDNOIR)
  1942. CALL POLRL(ITR,XTR,YTR,ZTR)
  1943. CALL CHCOUL(ICOLE)
  1944. ENDIF
  1945. ITR=0
  1946. 4117 CONTINUE
  1947. ELSE
  1948. DO 4114 J=IDEP,IFIN,2
  1949. IF (J.LE.IFIN2) THEN
  1950. I1=ICPR(IPT1.NUM(KSEGM(J),I))
  1951. I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  1952. ELSE
  1953. I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  1954. I2=ICPR(IPT1.NUM(KSEGM(1),I))
  1955. ENDIF
  1956. XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  1957. YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  1958. ZR=ZG+(XPROJ(3,I1)-ZG)*XECLAT
  1959. IF (I1.NE.I3) THEN
  1960. if (ifades.eq.0) then
  1961. IF (ITR.NE.1) call POLRL(ITR,XTR,YTR,ZTR)
  1962. else
  1963. IF (ITR.NE.1) CALL trface(ITR,XTR,YTR,ZTR,zn,icole,ieff)
  1964. endif
  1965. ITR=1
  1966. XTR(1)=XR
  1967. YTR(1)=YR
  1968. ZTR(1)=ZR
  1969. ENDIF
  1970. XR=XG+(XPROJ(1,I2)-XG)*XECLAT
  1971. YR=YG+(XPROJ(2,I2)-YG)*XECLAT
  1972. ZR=ZG+(XPROJ(3,I2)-ZG)*XECLAT
  1973. ITR=ITR+1
  1974. XTR(ITR)=XR
  1975. YTR(ITR)=YR
  1976. ZTR(ITR)=ZR
  1977. I3=I2
  1978. 4114 CONTINUE
  1979. if (ifades.eq.0) then
  1980. IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  1981. else
  1982. IF (ITR.NE.1) CALL trface(ITR,XTR,YTR,ZTR,zn,icole,ieff)
  1983. endif
  1984. ITR=1
  1985. ENDIF
  1986. 4115 CONTINUE
  1987. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1988. 4111 CONTINUE
  1989. SEGDES MELEME
  1990. 4202 CONTINUE
  1991.  
  1992. C----------------------------------------------------------
  1993. C TRAITEMENT DES PARAMETRES TELS QUE NOEUD,QUALI,...
  1994. C (AVANT AFFICHAGE)
  1995. C----------------------------------------------------------
  1996. IF (IQUALI.EQ.0) GOTO 500
  1997. SEGACT XPROJ,IVU,ICPR
  1998. PAS=(X2-X1)/(XMA-XMI)
  1999. CALL INSEGT(3,IRESS)
  2000. C ON MET LES NOMS LA OU ON PEUT
  2001. if(nbesc.ne.0) segact ipiloc
  2002. DO 501 IOB=1,LMNNOM
  2003. C IGNORER LES OBJETS TEMPORAIRES OU INVALIDES
  2004. ICOLE=0
  2005. IF (INOOB2(IOB).NE.'MAILLAGE') GOTO 511
  2006. IPVH=INOOB1(IOB)
  2007. IDEBCH=IPCHAR(IPVH)
  2008. IFINCH=IPCHAR(IPVH+1)-1
  2009. TXT= ICHARA(IDEBCH:IFINCH)
  2010. IF (TXT(1:1).EQ.'#') GOTO 501
  2011. IF (TXT(1:1).EQ.' ') GOTO 501
  2012. IPT4=IOUEP2(IOB)
  2013. IF (IPT4.EQ.0) GOTO 501
  2014. SEGACT IPT4
  2015. XP=0
  2016. YP=0
  2017. ZP=0
  2018. NP=0
  2019. IPT5=IPT4
  2020. DO 503 ISB=1,MAX(1,IPT4.LISOUS(/1))
  2021. IF (IPT4.LISOUS(/1).NE.0) THEN
  2022. IPT5=IPT4.LISOUS(ISB)
  2023. SEGACT IPT5
  2024. ENDIF
  2025. CPM NBCOUL-1 au lieu de 7
  2026. DO 507 I=1,NBCOUL-1
  2027. ITEST(I)=0
  2028. 507 CONTINUE
  2029. DO 504 J=1,IPT5.NUM(/2)
  2030. IF (IPT5.ICOLOR(J).NE.0) THEN
  2031. ITEST(IPT5.ICOLOR(J))=1
  2032. ELSE
  2033. C ITEST(7)=1
  2034. ENDIF
  2035. DO 5041 I=1,IPT5.NUM(/1)
  2036. K=ICPR(IPT5.NUM(I,J))
  2037. IF (K.EQ.0) GOTO 505
  2038. IF (IVU(K).LE.0) GOTO 5041
  2039. NP=NP+1
  2040. XP=XP+XPROJ(1,K)
  2041. YP=YP+XPROJ(2,K)
  2042. ZP=ZP+XPROJ(3,K)
  2043. 5041 CONTINUE
  2044. 504 CONTINUE
  2045. IF (IPT4.LISOUS(/1).NE.0) SEGDES IPT5
  2046. 503 CONTINUE
  2047. SEGDES IPT4
  2048. IF (NP.EQ.0) GOTO 501
  2049. XP=XP/NP
  2050. YP=YP/NP
  2051. ZP=ZP/NP
  2052. C IF (XP.LT.XMI.OR.XP.GT.XMA.OR.YP.LT.YMI.OR.YP.GT.YMA) GOTO 501
  2053. ICOLE=0
  2054. CPM NBCOUL-1 au lieu de 7
  2055. C couleur avec melange eventuel si plusieurs
  2056. DO 508 I=1,NBCOUL-1
  2057. IF (ITEST(I).EQ.1) THEN
  2058. IF (ICOLE.EQ.0) THEN
  2059. ICOLE=I
  2060. ELSE
  2061. ICOLE=ITABM(ICOLE,I)
  2062. ENDIF
  2063. ENDIF
  2064. 508 CONTINUE
  2065. IF (IDEFCO.EQ.1.AND.ICOLE.NE.IICOL) GOTO 501
  2066. CALL CHCOUL(ICOLE)
  2067. XP=PAS*(XP-XMI)+X1
  2068. YP=PAS*(YP-YMI)+Y1
  2069. ZP=PAS*(ZP-ZMI)+ZMI
  2070. C TXT= INOOB1(IOB)
  2071. CALL TRLABL(XP,YP,ZP,TXT,8,0.15)
  2072. GOTO 501
  2073. 505 CONTINUE
  2074. SEGDES IPT4,IPT5
  2075. 511 CONTINUE
  2076. C AU TOUR DES POINTS NOMMES
  2077. IF (INOOB2(IOB).NE.'POINT ') GOTO 501
  2078. IF (IOUEP2(IOB).EQ.0) GOTO 501
  2079. K=ICPR(IOUEP2(IOB))
  2080. IF (K.EQ.0) GOTO 501
  2081. IF (IVU(K).LE.0) GOTO 501
  2082. C IF (XPROJ(1,K).LT.XMI.OR.XPROJ(1,K).GT.XMA) GOTO 501
  2083. C IF (XPROJ(2,K).LT.YMI.OR.XPROJ(2,K).GT.YMA) GOTO 501
  2084. ITRUC=0
  2085. IF (IDEFCO.EQ.1) THEN
  2086. 512 DO 509 I=1,NBCONR
  2087. CPM ?????????? pb si codage KON en binaire ???????????
  2088. IF (KON(2,I,K).EQ.IICOL) THEN
  2089. ITRUC=1
  2090. GOTO 510
  2091. ENDIF
  2092. 509 CONTINUE
  2093. IF (KON(1,NBCON,K).NE.0) THEN
  2094. K=KON(1,NBCON,K)
  2095. GOTO 512
  2096. ENDIF
  2097. ELSE
  2098. ITRUC=1
  2099. ENDIF
  2100. 510 IF (ITRUC.EQ.1) THEN
  2101. CALL CHCOUL(0)
  2102. XP=XPROJ(1,K)
  2103. YP=XPROJ(2,K)
  2104. ZP=XPROJ(3,K)
  2105. XP=PAS*(XP-XMI)+X1
  2106. YP=PAS*(YP-YMI)+Y1
  2107. ZP=PAS*(ZP-ZMI)+ZMI
  2108. IPVH=INOOB1(IOB)
  2109. IDEBCH=IPCHAR(IPVH)
  2110. IFINCH=IPCHAR(IPVH+1)-1
  2111. TXT= ICHARA(IDEBCH:IFINCH)
  2112. CALL TRLABL(XP,YP,ZP,TXT,8,0.15)
  2113. ENDIF
  2114. 501 CONTINUE
  2115. if(nbesc.ne.0) segdes ipiloc
  2116. IF (IRESU.EQ.3) GOTO 6101
  2117. 500 IF (INUMNO.EQ.0) GOTO 531
  2118. SEGACT XPROJ,IVU,ICPR
  2119. PAS=(X2-X1)/(XMA-XMI)
  2120. CALL INSEGT(4,IRESS)
  2121. C INDICATION DES NUMEROS DE NOEUDS
  2122. CALL CHCOUL(0)
  2123. DO 530 I=1,NBPTS
  2124. K=ICPR(I)
  2125. IF (K.EQ.0) GOTO 530
  2126. IF (IVU(K).LE.0) GOTO 530
  2127. C IF (XPROJ(1,K).LT.XMI.OR.XPROJ(1,K).GT.XMA) GOTO 530
  2128. C IF (XPROJ(2,K).LT.YMI.OR.XPROJ(2,K).GT.YMA) GOTO 530
  2129. ITRUC=0
  2130. IF (IDEFCO.EQ.1) THEN
  2131. 521 DO 519 J=1,NBCONR
  2132. CPM ?????????? pb si codage KON en binaire ???????????
  2133. IF (KON(2,J,K).EQ.IICOL) THEN
  2134. ITRUC=1
  2135. GOTO 520
  2136. ENDIF
  2137. 519 CONTINUE
  2138. IF (KON(1,NBCON,K).NE.0) THEN
  2139. K=KON(1,NBCON,K)
  2140. GOTO 521
  2141. ENDIF
  2142. ELSE
  2143. ITRUC=1
  2144. ENDIF
  2145. 520 IF (ITRUC.EQ.1) THEN
  2146. IF (I.LT.10) THEN
  2147. FMTX='(I1,7X)'
  2148. ELSEIF (I.LT.100) THEN
  2149. FMTX='(I2,6X)'
  2150. ELSEIF (I.LT.1000) THEN
  2151. FMTX='(I3,5X)'
  2152. ELSEIF (I.LT.10000) THEN
  2153. FMTX='(I4,4X)'
  2154. ELSEIF (I.LT.100000) THEN
  2155. FMTX='(I5,3X)'
  2156. ELSEIF (I.LT.1000000) THEN
  2157. FMTX='(I6,2X)'
  2158. ENDIF
  2159. WRITE (TXT,FMT=FMTX) I
  2160. XP=XPROJ(1,K)
  2161. YP=XPROJ(2,K)
  2162. ZP=XPROJ(3,K)
  2163. XP=PAS*(XP-XMI)+X1
  2164. YP=PAS*(YP-YMI)+Y1
  2165. ZP=PAS*(ZP-ZMI)+ZMI
  2166. CALL TRLABL(XP,YP,ZP,TXT,8,0.15)
  2167. ENDIF
  2168. 530 CONTINUE
  2169. IF (IRESU.EQ.4) GOTO 6101
  2170. 531 CONTINUE
  2171. C+++*
  2172. IF (LABCO2.EQ.0) GOTO 538
  2173. MVECTS=MVECTE
  2174. MVECTE=LABCO2(3,IDEF)
  2175. IF (MVECTE.EQ.0) GOTO 538
  2176. SEGACT XPROJ,IVU,ICPR
  2177.  
  2178. C TRACE DES VECTEURS SI IL Y A LIEU
  2179. SEGACT MVECTE
  2180. NVEC=NOCOUL(/1)
  2181. KABCO2=LABCO2(1,IDEF)
  2182. KXPRO2=LABCO2(2,IDEF)
  2183. DO 541 IVEC=1,NVEC
  2184. C Mots reserves : contraintes principales / fissures
  2185. CALL PLACE(MOVE,6,IPLA,NOCOVE(IVEC,1))
  2186. IF (IPLA.EQ.0) THEN
  2187. C Cas classique des vecteurs
  2188. CPM NLEGMX au lieu de 8
  2189. IF (NVECL.LT.NLEGMX) THEN
  2190. IFLE = 0
  2191. NVECL=NVECL+1
  2192. VAMPF(NVECL)=REAL(AMPF(IVEC))
  2193. IF (VAMPF(NVECL).LT.0) IFLE = -1
  2194. NVCOL(NVECL)=NOCOUL(IVEC)
  2195. NVLEG(1,NVECL)=NOCOVE(IVEC,1)
  2196. cbp petit ajout pour eviter pb si vecteurs crees depuis mchaml
  2197. NVLEG(2,NVECL)=' '
  2198. NVLEG(3,NVECL)=' '
  2199. IDVECT=NOCOVE(/3)
  2200. IF(IDVECT.GT.1) THEN
  2201. NVLEG(2,NVECL)=NOCOVE(IVEC,2)
  2202. IF (IDIM.EQ.3) NVLEG(3,NVECL)=NOCOVE(IVEC,3)
  2203. ENDIF
  2204. cbp fin petit ajout
  2205. ENDIF
  2206. ELSE
  2207. C Cas des contraintes principales
  2208. IF (IPLA.LE.3) IFLE = 1
  2209. C Cas des fissures
  2210. IF (IPLA.GT.3) IFLE = 2
  2211. IF (IFLE.EQ.1.AND.NOCOVE(2,1).EQ.NOCOVE(1,1)) THEN
  2212. NVECL = 1
  2213. VAMPF(1)=REAL(AMPF(1))
  2214. NVCOL(1)=NOCOUL(1)
  2215. NVLEG(1,1)=NOCOVE(1,1)
  2216. ELSE
  2217. NVECL = 2
  2218. VAMPF(1)=REAL(AMPF(1))
  2219. NVCOL(1)=NOCOUL(1)
  2220. NVLEG(1,1)=NOCOVE(1,1)
  2221. VAMPF(2)=REAL(AMPF(2))
  2222. NVCOL(2)=NOCOUL(2)
  2223. NVLEG(1,2)=NOCOVE(2,1)
  2224. IF (IDIM.EQ.3) THEN
  2225. NVECL = 3
  2226. VAMPF(3)=REAL(AMPF(3))
  2227. NVCOL(3)=NOCOUL(3)
  2228. NVLEG(1,3)=NOCOVE(3,1)
  2229. ENDIF
  2230. ENDIF
  2231. ENDIF
  2232. XPRO2=KXPRO2(IVEC)
  2233. ICOR2=KABCO2(2,IVEC)
  2234. SEGACT XPRO2,ICOR2,XPROJ,IVU,ICPR
  2235. INVCOU=NOCOUL(IVEC)
  2236. CALL CHCOUL(INVCOU)
  2237. DO 540 I=1,NBPTS
  2238. K=ICPR(I)
  2239. IF (K.EQ.0) GOTO 540
  2240. IF (ICOR2(K).EQ.0) GOTO 540
  2241. IF (IVU(K).LE.0) GOTO 540
  2242. IF (IFLE.EQ.-1) THEN
  2243. C Fleches pointant vers les points
  2244. UX=XPROJ(1,K)-XPRO2(1,K)
  2245. UY=XPROJ(2,K)-XPRO2(2,K)
  2246. UZ=XPROJ(3,K)-XPRO2(3,K)
  2247. XTR(1)=XPRO2(1,K)
  2248. YTR(1)=XPRO2(2,K)
  2249. ZTR(1)=XPRO2(3,K)
  2250. XTR(2)=XPROJ(1,K)-UX/10.
  2251. YTR(2)=XPROJ(2,K)-UY/10.
  2252. ZTR(2)=XPROJ(3,K)-UZ/10.
  2253. U1=XPROJ(1,K)-UX/3-UY/5
  2254. V1=XPROJ(2,K)-UY/3+UX/5
  2255. W1=XPROJ(3,K)
  2256. XTR(3)=U1
  2257. YTR(3)=V1
  2258. ZTR(3)=W1
  2259. XTR(4)=XPROJ(1,K)
  2260. YTR(4)=XPROJ(2,K)
  2261. ZTR(4)=XPROJ(3,K)
  2262. U1=XPROJ(1,K)-UX/3+UY/5
  2263. V1=XPROJ(2,K)-UY/3-UX/5
  2264. W1=XPROJ(3,K)
  2265. XTR(5)=U1
  2266. YTR(5)=V1
  2267. ZTR(5)=W1
  2268. XTR(6)=XPROJ(1,K)-UX/10.
  2269. YTR(6)=XPROJ(2,K)-UY/10.
  2270. ZTR(6)=XPROJ(3,K)
  2271. CALL POLRL(6,XTR,YTR,ZTR)
  2272. ELSE IF (IFLE.EQ.0) THEN
  2273. C Fleches partant des points
  2274.  
  2275. XTR(1)=XPROJ(1,K)
  2276. YTR(1)=XPROJ(2,K)
  2277. ZTR(1)=XPROJ(3,K)
  2278. UX=XPRO2(1,K)-XPROJ(1,K)
  2279. UY=XPRO2(2,K)-XPROJ(2,K)
  2280. UZ=XPRO2(3,K)-XPROJ(3,K)
  2281. XTR(2)=XPRO2(1,K)-UX/10.
  2282. YTR(2)=XPRO2(2,K)-UY/10.
  2283. ZTR(2)=XPRO2(3,K)
  2284. U1=XPRO2(1,K)-UX/3-UY/5
  2285. V1=XPRO2(2,K)-UY/3+UX/5
  2286. W1=XPRO2(3,K)
  2287. XTR(3)=U1
  2288. YTR(3)=V1
  2289. ZTR(3)=W1
  2290. XTR(4)=XPRO2(1,K)
  2291. YTR(4)=XPRO2(2,K)
  2292. ZTR(4)=XPRO2(3,K)
  2293. U1=XPRO2(1,K)-UX/3+UY/5
  2294. V1=XPRO2(2,K)-UY/3-UX/5
  2295. W1=XPRO2(3,K)
  2296. XTR(5)=U1
  2297. YTR(5)=V1
  2298. ZTR(5)=W1
  2299. XTR(6)=XPRO2(1,K)-UX/10.
  2300. YTR(6)=XPRO2(2,K)-UY/10.
  2301. ZTR(6)=XPRO2(3,K)
  2302. CALL POLRL(6,XTR,YTR,ZTR)
  2303. ELSE IF (IFLE.EQ.1) THEN
  2304. C contraintes principales
  2305. IF (ICOR2(K).EQ.1) THEN
  2306. NTR = 6
  2307. XTR(1) = XPROJ(1,K)
  2308. YTR(1) = XPROJ(2,K)
  2309. ZTR(1) = XPROJ(3,K)
  2310. UX = XPRO2(1,K) - XPROJ(1,K)
  2311. UY = XPRO2(2,K) - XPROJ(2,K)
  2312. UZ = XPRO2(3,K) - XPROJ(3,K)
  2313. XTR(2) = XPRO2(1,K) - UX/10
  2314. YTR(2) = XPRO2(2,K) - UY/10
  2315. ZTR(2) = XPRO2(3,K)
  2316. XTR(3) = XPRO2(1,K) - UX/3 - UY/5
  2317. YTR(3) = XPRO2(2,K) - UY/3 + UX/5
  2318. ZTR(3) = XPRO2(3,K)
  2319. XTR(4) = XPRO2(1,K)
  2320. YTR(4) = XPRO2(2,K)
  2321. ZTR(4) = XPRO2(3,K)
  2322. XTR(5) = XPRO2(1,K) - UX/3 + UY/5
  2323. YTR(5) = XPRO2(2,K) - UY/3 - UX/5
  2324. ZTR(5) = XPRO2(3,K)
  2325. XTR(6) = XPRO2(1,K) - UX/10.
  2326. YTR(6) = XPRO2(2,K) - UY/10.
  2327. ZTR(6) = XPRO2(3,K)
  2328. CALL POLRL(NTR,XTR,YTR,ZTR)
  2329. ELSE
  2330. NTR = 6
  2331. XTR(1) = XPROJ(1,K)
  2332. YTR(1) = XPROJ(2,K)
  2333. ZTR(1) = XPROJ(3,K)
  2334. XTR(2) = XPRO2(1,K)
  2335. YTR(2) = XPRO2(2,K)
  2336. ZTR(2) = XPRO2(3,K)
  2337. UX = XPRO2(1,K) - XPROJ(1,K)
  2338. UY = XPRO2(2,K) - XPROJ(2,K)
  2339. UZ = XPRO2(3,K) - XPROJ(3,K)
  2340. XTR(3) = XPRO2(1,K) + UX/3 + UY/5
  2341. YTR(3) = XPRO2(2,K) + UY/3 - UX/5
  2342. ZTR(3) = XPRO2(3,K)
  2343. XTR(4) = XPRO2(1,K) + UX/10
  2344. YTR(4) = XPRO2(2,K) + UY/10
  2345. ZTR(4) = XPRO2(3,K)
  2346. XTR(5) = XPRO2(1,K) + UX/3 - UY/5
  2347. YTR(5) = XPRO2(2,K) + UY/3 + UX/5
  2348. ZTR(5) = XPRO2(3,K)
  2349. XTR(6) = XPRO2(1,K)
  2350. YTR(6) = XPRO2(2,K)
  2351. ZTR(6) = XPRO2(3,K)
  2352. CALL POLRL(NTR,XTR,YTR,ZTR)
  2353. ENDIF
  2354. ELSE IF (IFLE.EQ.2) THEN
  2355. C fissures
  2356. IF (ICOR2(K).EQ.-1) GOTO 540
  2357. NTR = 2
  2358. XTR(1) = XPROJ(1,K)
  2359. YTR(1) = XPROJ(2,K)
  2360. ZTR(1) = XPROJ(3,K)
  2361. XTR(2) = XPRO2(1,K)
  2362. YTR(2) = XPRO2(2,K)
  2363. ZTR(2) = XPRO2(3,K)
  2364. CALL POLRL(NTR,XTR,YTR,ZTR)
  2365. ENDIF
  2366. 540 CONTINUE
  2367. SEGSUP XPRO2,ICOR2
  2368. 541 CONTINUE
  2369. SEGSUP KXPRO2,KABCO2
  2370. MVECTE = MVECTS
  2371. 538 CONTINUE
  2372. IF (INUMEL.EQ.0) GOTO 532
  2373. SEGACT XPROJ,IVU,ICPR
  2374. PAS=(X2-X1)/(XMA-XMI)
  2375. CALL INSEGT(5,IRESS)
  2376. SEGACT MELEME
  2377. IPT1=MELEME
  2378. IF (MCOUP.NE.0) GOTO 537
  2379. DO 534 II=1,MAX(1,LISOUS(/1))
  2380. IF (LISOUS(/1).NE.0) IPT1=LISOUS(II)
  2381. SEGACT IPT1
  2382. NBNN=IPT1.NUM(/1)
  2383. NBELEM=IPT1.NUM(/2)
  2384. DO 535 L=1,NBELEM
  2385. XG=0.
  2386. YG=0.
  2387. ZG=0.
  2388. NG=0
  2389. DO 536 N=1,NBNN
  2390. I=ICPR(IPT1.NUM(N,L))
  2391. IF (IVU(I).LE.0) GOTO 536
  2392. XG=XG+XPROJ(1,I)
  2393. YG=YG+XPROJ(2,I)
  2394. ZG=ZG+XPROJ(3,I)
  2395. NG=NG+1
  2396. 536 CONTINUE
  2397. IF (NG.EQ.0) GOTO 535
  2398. XG=XG/NG
  2399. YG=YG/NG
  2400. ZG=ZG/NG
  2401. C IF (XG.LT.XMI.OR.XG.GT.XMA.OR.YG.LT.YMI.OR.YG.GT.YMA) GOTO 535
  2402. INVCOU=IPT1.ICOLOR(L)
  2403. C IF (INVCOU.EQ.0) INVCOU=IDCOUL
  2404. IF (IDEFCO.EQ.1.AND.INVCOU.NE.IICOL) GOTO 535
  2405. CALL CHCOUL(INVCOU)
  2406. IF (L.LT.10) THEN
  2407. FMTX='(I1,7X)'
  2408. ELSEIF (L.LT.100) THEN
  2409. FMTX='(I2,6X)'
  2410. ELSEIF (L.LT.1000) THEN
  2411. FMTX='(I3,5X)'
  2412. ELSEIF (L.LT.10000) THEN
  2413. FMTX='(I4,4X)'
  2414. ELSEIF (L.LT.100000) THEN
  2415. FMTX='(I5,3X)'
  2416. ELSEIF (L.LT.1000000) THEN
  2417. FMTX='(I6,2X)'
  2418. ENDIF
  2419. WRITE (TXT,FMT=FMTX) L
  2420. XG=PAS*(XG-XMI)+X1
  2421. YG=PAS*(YG-YMI)+Y1
  2422. ZG=PAS*(ZG-ZMI)+ZMI
  2423. CALL TRLABL(XG,YG,ZG,TXT,8,0.15)
  2424. 535 CONTINUE
  2425. IF (LISOUS(/1).NE.0) SEGDES IPT1
  2426. 534 CONTINUE
  2427. 537 SEGDES MELEME
  2428. IF (IRESU.EQ.5.OR.IRESU.EQ.7) GOTO 6101
  2429. 532 CONTINUE
  2430. IF (IDEFOR.EQ.0) GOTO 6101
  2431. SEGSUP KON,XPROJ,ICPR,IVU
  2432. IF (XPRO2.NE.0) SEGSUP XPRO2
  2433. IF (MCOUP.NE.0) THEN
  2434. C NETTOYAGE APRES COUPE
  2435. C SEGSUP MCOUP
  2436. SEGACT MCOORD*MOD
  2437. C SEGADJ MCOORD
  2438. C SEGACT MELEME
  2439. C DO 8801 IO=1,LISOUS(/1)
  2440. C* IPT1=LISOUS(IO)
  2441. C SEGSUP IPT1
  2442. C 8801 CONTINUE
  2443. C SEGSUP MELEME
  2444. ENDIF
  2445. GOTO 6099
  2446. C<<<< FIN DE BOUCLE SUR LES DEFORMEES OU VECTEURS <<<<<<<<<<<<<<<<<<<<<<
  2447.  
  2448.  
  2449. C---- POINT D'ARRIVEE EN FIN DE BOUCLE SUR LES DEFORMEES OU VECTEURS ---
  2450. 6100 CONTINUE
  2451. IDEFS=IDEFOR
  2452. IDEFOR=0
  2453. IF (IANIM.NE.0) CALL TRIMAG(NDEF+1)
  2454. IF (KABEL.NE.0) SEGSUP KABEL
  2455. IF (KABEL2.NE.0) SEGSUP KABEL2
  2456. IF (KABCPR.NE.0) SEGSUP KABCPR
  2457. IF (KABCP2.NE.0) SEGSUP KABCP2
  2458. SEGSUP KABCOR
  2459. IF (KABCO3.NE.0) SEGSUP KABCO3
  2460. IF (LABCO2.NE.0) SEGSUP LABCO2
  2461. IF (LABCO3.NE.0) SEGSUP LABCO3
  2462. 6101 CONTINUE
  2463. CALL MAJSEG(1,IRESU,IQUALI,INUMNO,INUMEL)
  2464. IF (ZCHAM) THEN
  2465. C ZCHAM=.TRUE.
  2466. SEGACT MCHPOI,icpr,vcpcha
  2467. do ibc=1,ipchp(/1)
  2468. msoupo=ipchp(ibc)
  2469. segact msoupo
  2470. do ibcn=1,nocomp(/2)
  2471. if(compch(lcomp).eq.nocomp(ibcn)) go to 6108
  2472. enddo
  2473. go to 6107
  2474. 6108 continue
  2475. IPT6=IGEOC
  2476. SEGACT IPT6
  2477. MPOVAL=IPOVAL
  2478. SEGACT MPOVAL
  2479. do I=1, IPT6.NUM(/2)
  2480. IJ=IPT6.NUM(1,I)
  2481. ijj=icpr(ij)
  2482. WRITE(VALCH,FMT='(E10.3)') vcpcha(ij)
  2483. CALL TRLABL(XPROJ(1,IJj),XPROJ(2,IJj),0.,
  2484. $ VALCH,LEN(VALCH),0.15)
  2485. enddo
  2486. segdes ipt6,mpoval
  2487. 6107 continue
  2488. segdes msoupo
  2489. enddo
  2490. segdes mchpoi,icpr,vcpcha
  2491. ENDIF
  2492.  
  2493. * option NOLEN : pas d'informations
  2494. IF(ZNOLE) GOTO 6105
  2495. C BERTIN : fin affichage CHAMPOIN
  2496. IF (INWDS.AND.VALEUR) THEN
  2497. C AFFICHAGE DES LABELS DES ISOVALEURS
  2498. CALL FVALIS(1,IRESU,NHAUT,NISO)
  2499. iresu=3
  2500. CALL INSEGT(7,iresu)
  2501. CALL CHCOUL(0)
  2502. NHAUT=NHAUT+INT(YHAUT)
  2503.  
  2504. NDEC=0
  2505. IF (NISO.NE.0) THEN
  2506. C Legende des isovaleurs
  2507. IF(TXISO.NE.' ') VALISO=TXISO
  2508. IF (NCOMP.NE.0) VALISO=COMPCH(LCOMP)(1:12)
  2509. LVS=LONG(VALISO)
  2510. CALL TRLABL(XHAUT+0.1,FLOAT(NHAUT+2),0.,VALISO(1:LVS),LVS,0.17)
  2511. C min et max
  2512. WRITE (ZONE,FMT='(1PE9.2)') VCHMIN
  2513. CALL TRLABL(XHAUT+0.,FLOAT(NHAUT),0.,'>'//ZONE,10,0.17)
  2514.  
  2515. IF (ZDATE) CALL TRLABL(-1.4,FLOAT(NHAUT-50),0.,BUFFER,26,
  2516. $ 0.17)
  2517. WRITE (ZONE,FMT='(1PE9.2)') VCHMAX
  2518. CALL TRLABL(XHAUT+0.,FLOAT(NHAUT+1),0.,'<'//ZONE,10,0.17)
  2519. C NISO=MIN(15,NISO)
  2520. C NDEC : amplitude verticale de la gamme d'isovaleurs
  2521. NDEC = 25
  2522. PDEC = REAL(NDEC)
  2523. PDDEC= PDEC/NISO
  2524. cBP pour espacer les legendes avec VING DIX ou CINQ labels maxi
  2525. XDEC=0.98
  2526. if(NDEC2.eq.1) XDEC=XDEC*25./21.
  2527. if(NDEC2.eq.2) XDEC=XDEC*25./11.
  2528. if(NDEC2.eq.3) XDEC=XDEC*25./6.
  2529. FAIT = -1
  2530. CPM NHAUT= NHAUT
  2531. NBAS = NHAUT - 1 - NDEC
  2532. DO 6102 I=1,NISO
  2533. PYB = NBAS + ((I-1)*PDDEC)
  2534. IF (ISOTYP.NE.0) THEN
  2535. C petit carre colore
  2536. PX(1)=XHAUT+0.
  2537. PX(2)=XHAUT+0.09
  2538. PX(3)=XHAUT+0.09
  2539. PX(4)=XHAUT+0.
  2540. PY(1)=PYB
  2541. PY(2)=PYB
  2542. PY(3)=PYB + PDDEC
  2543. PY(4)=PYB + PDDEC
  2544. C si moins de 16 isov., on prend une couleur
  2545. C correspondante sur deux (NISO<8) ou sur une (NISO>=8)
  2546. IF (NISO.LT.16) THEN
  2547. c CALL TRAISO(4,PX,PY,ICOTAB(I*(2-NISO/8)))
  2548. CALL TRAISO(4,PX,PY,ICOTAB(ISOTAB(I,NISO)))
  2549. ELSE
  2550. CALL TRAISO(4,PX,PY,I)
  2551. ENDIF
  2552. IF (I*PDDEC-FAIT.LT. XDEC ) GOTO 6102
  2553. C valeur seuil pour l'affichage de la legende isovaleur
  2554. IF (I.GT.1) THEN
  2555. WRITE (ZONE,FMT='(1PG9.2)') VCHC(I-1)
  2556. CALL CHCOUL(0)
  2557. CALL TRLABL(XHAUT+0.1,PYB,0.,ZONE,10,0.17)
  2558. ENDIF
  2559. FAIT=I*PDDEC
  2560. ELSE
  2561. C lettre coloree
  2562. IF (NISO.LT.13) THEN
  2563. C CALL CHCOUL(ICOTAB(I*(2-NISO/8)))
  2564. CALL CHCOUL(ICOTAB(ISOTA0(I,NISO)))
  2565. ELSE
  2566. Csg CALL CHCOUL(I)
  2567. CALL CHCOUL(ICOTAB(MOD(I,12)+1))
  2568. ENDIF
  2569. IF (I*PDDEC-FAIT.LT. 0.98 ) GOTO 6102
  2570. CALL TRLABL(XHAUT+0.002,PYB,0.,ABCDEF(I:I),1,0.17)
  2571. C valeur seuil
  2572. WRITE (ZONE,FMT='(1PG9.2)') VCHC(I)
  2573. CALL TRLABL(XHAUT+0.1,PYB,0.,ZONE,10,0.17)
  2574. FAIT=I*PDDEC
  2575. ENDIF
  2576. 6102 CONTINUE
  2577. ELSE IF (KDEFOR.NE.0) THEN
  2578. CALL TRLABL(XHAUT+0.,FLOAT(NHAUT),0.,'AMPLITUDE',9,0.17)
  2579. CPM NDEFMX au lieu de 7
  2580. NDEF=MIN(NDEF,NDEFMX)
  2581. NBAS = NHAUT - 1 - NDEF
  2582. DO 6103 I=1,NDEF
  2583. CALL CHCOUL(ICHL(I))
  2584. XXXX = AMPIMP(I)
  2585. IF(AMPIMP(I).GE.XSGRAN/2.) XXXX = VCHC(I)
  2586. WRITE (ZONE,FMT='(1PG9.2)') XXXX
  2587. CALL TRLABL(XHAUT+0.,FLOAT(NBAS+I),0.,ZONE,9,0.17)
  2588. 6103 CONTINUE
  2589. ENDIF
  2590. IF (NISO.NE.0.AND.KDEFOR.NE.0) THEN
  2591. CALL CHCOUL(0)
  2592. CALL TRLABL(0.1,FLOAT(NHAUT-NDEC-3),0.,'AMPLITUDE',9,0.17)
  2593. CALL TRLABL(0.1,FLOAT(NHAUT-NDEC-4),0.,'DEFORMEE ',9,0.17)
  2594. WRITE (ZONE,FMT='(1PG9.2)') SIAMPL
  2595. CALL TRLABL(0.,FLOAT(NHAUT - 6 - NDEC),0.,ZONE,9,0.17)
  2596. ENDIF
  2597. IF (NVECL.NE.0) THEN
  2598. CALL TRBOX(0.75,0.75)
  2599. CALL CHCOUL(0)
  2600. C+++*
  2601. CALL TRLABL(-0.1,FLOAT(NHAUT-NDEC-8),0.,
  2602. & 'COMPOSANTES',11,0.17)
  2603. IF (IFLE.NE.0) THEN
  2604. IF (IFLE.EQ.1) THEN
  2605. CALL TRLABL(-0.1,NHAUT-NDEC-8.75,0.,
  2606. & 'CONTRAINTES',11,0.17)
  2607. ELSE
  2608. CALL TRLABL(0.1,NHAUT-NDEC-8.75,0.,'FISSURES',8,0.17)
  2609. ENDIF
  2610. NBAS = NHAUT - 10 - NDEC - NVECL
  2611. DO I=1,NVECL
  2612. CALL CHCOUL(NVCOL(I))
  2613. ZONE=NVLEG(1,I)
  2614. CALL TRLABL(0.,FLOAT(NBAS+I),0.,ZONE,4,0.17)
  2615. ENDDO
  2616. ELSE
  2617. CALL TRLABL(0.1,NHAUT-NDEC-8.75,0.,'VECTEURS',8,0.17)
  2618. NBAS = NHAUT - 10 - NDEC - NVECL
  2619. DO 6104 I=1,NVECL
  2620. CALL CHCOUL(NVCOL(I))
  2621. IF (IDIM.EQ.2) ZONE=NVLEG(1,I)//NVLEG(2,I)
  2622. IF (IDIM.EQ.3) ZONE=NVLEG(1,I)//NVLEG(2,I)//NVLEG(3,I)
  2623. CALL TRLABL(0.,FLOAT(NBAS+I),0.,ZONE,12,0.17)
  2624. 6104 CONTINUE
  2625. ENDIF
  2626. ENDIF
  2627. INWDS2=INWDS
  2628. INWDS=.FALSE.
  2629. CALL FVALIS(0,IRESU,NHAUT,NISO)
  2630. ENDIF
  2631.  
  2632.  
  2633. C----------------------------------------------------------
  2634. C
  2635. C POST TRAITEMENT DE L'AFFICHAGE : ZOOM,NOM,IMPRESSION ...
  2636. C
  2637. C----------------------------------------------------------
  2638.  
  2639. C
  2640. 6105 CONTINUE
  2641. C AFFICHAGE DES CLES GRAPHIQUES
  2642. C AFFICHAGE DES CLES GRAPHIQUES
  2643. NCASE=10
  2644. LLONG=13
  2645. LEGEND(1)=' Fin trace '
  2646. LEGEND(2)=' Zoom/Pan'
  2647. LEGEND(3)=' Rotation'
  2648. LEGEND(4)=' Coupe '
  2649. LEGEND(5)=' Valeur'
  2650. LEGEND(6)='Qualification'
  2651. LEGEND(7)=' Noeuds'
  2652. LEGEND(8)=' Elements'
  2653. LEGEND(9)=' Animation'
  2654. C attention dans xtrini on teste la chaine " Animation"
  2655. LEGEND(10)=' Options'
  2656.  
  2657. if (idim.ne.3) then
  2658. legend(3)=' '
  2659. legend(4)=' '
  2660. endif
  2661. IF (NISO.NE.0.OR.NDEF.NE.0.OR.NVECL.NE.0) THEN
  2662. LEGEND(6)=' '
  2663. LEGEND(7)=' '
  2664. LEGEND(8)=' '
  2665. IF (KDEFOR.NE.0.OR.IVEC.NE.0) LEGEND(5)=' '
  2666. IF (IANIM.EQ.0) LEGEND(9)=' '
  2667. ELSE
  2668. LEGEND(5)=' '
  2669. LEGEND(9)=' '
  2670. ENDIF
  2671. IF (KDEFOR.NE.0) LEGEND(5)='Amplification'
  2672. IF (NCOMP.NE.0) LEGEND(6)='Composantes'
  2673. CALL MENU(LEGEND,NCASE,LLONG)
  2674. C
  2675. IRESU=0
  2676. C RECUPERATION DE LA CLE FRAPPEE
  2677. icle=-1
  2678. isort=0
  2679. CALL TRAFF(ICLE)
  2680. C TRAITEMENT
  2681. IF (ICLE.NE.0) THEN
  2682. IF (ICLE.EQ.1) THEN
  2683. CALL PRZOOM(IRESU,ISORT,IQUALI,INUMNO,INUMEL,
  2684. $ XMI,XMA,YMI,YMA)
  2685.  
  2686.  
  2687. ENDIF
  2688. IF (ICLE.EQ.2) THEN
  2689. CALL rotvu(ioeini,ioeil,cgrav,xmi,xma,ymi,yma,zmi,zma,axez)
  2690. GOTO 7001
  2691. ENDIF
  2692. IF (ICLE.EQ.4) THEN
  2693. IF (KDEFOR.EQ.0) THEN
  2694. C AFFICHAGE DE VALEUR D'ISO
  2695. PAS=(X2-X1)/(XMA-XMI)
  2696. CALL ISOINT(VCPCHA,MELEME,ICPR,XPROJ,IVU,PAS,
  2697. $ XMI,YMI,X1,Y1,mcham)
  2698. IRESU=2
  2699. GOTO 6101
  2700. ELSE
  2701. C (fdp) Modification de l'amplitude de maniere interactive
  2702. CALL AMPINT(NDEF,VCHC,SDEF,IIMP)
  2703. C (fdp) Dans le cas d'une deformee seule, on garde l'amplification
  2704. C saisie dans le COMMON AMPLIT (voir include CCTRACE)
  2705. C Cette valeur sera re-utilisee au prochain trace d'une
  2706. C deformee seule
  2707. IF (NDEF.EQ.1) THEN
  2708. AMPLIT=REAL(AMPIMP(IIMP))
  2709. SIAMPL=REAL(AMPIMP(IIMP))
  2710. ENDIF
  2711. GOTO 7001
  2712. ENDIF
  2713. ENDIF
  2714. IF (ICLE.EQ.5.AND.NCOMP.NE.0) THEN
  2715. CALL COMPINT(NCOMP,LCOMP,COMPCH)
  2716. GOTO 7001
  2717. ENDIF
  2718. IF (ICLE.EQ.5) CALL CHANG(IRESU,ISORT,IQUALI,3)
  2719. IF (ICLE.EQ.6) CALL CHANG(IRESU,ISORT,INUMNO,4)
  2720. IF (ICLE.EQ.7) CALL CHANG(IRESU,ISORT,INUMEL,5)
  2721. IF (ICLE.EQ.11) THEN
  2722. CALL FLGI
  2723. ISORT=0
  2724. ENDIF
  2725. IF (ICLE.EQ.12) THEN
  2726. CALL IMPR
  2727. ISORT=0
  2728. ENDIF
  2729. C BERTIN: Traitement de la coupe
  2730. IF (ICLE.EQ.3) THEN
  2731. C Ecriture de maniere permanente du barycentre e ICOUP1.
  2732. IF (ZCOM.EQ.0) THEN
  2733. CALL ECROBJ('MAILLAGE',MELEME)
  2734. CALL BARYCE
  2735. CALL LIROBJ('POINT',IBARY,1,IRETOU)
  2736. IREF=(IBARY-1)*(IDIM+1)
  2737. BARY(1)=REAL(XCOOR(IREF+1))
  2738. BARY(2)=REAL(XCOOR(IREF+2))
  2739. BARY(3)=REAL(XCOOR(IREF+3))
  2740. XB= BARY(1)
  2741. YB= BARY(2)
  2742. ZB= BARY(3)
  2743. ZCOM=1
  2744. nbpts=xcoor(/1)/(idim+1)
  2745. nbpts=nbpts+3
  2746. segadj mcoord
  2747. icoup1=nbpts-2
  2748. icoup2=nbpts-1
  2749. icoup3=nbpts
  2750. ENDIF
  2751.  
  2752. XE=REAL( XCOOR((IOEIL-1)*(idim+1)+1) )
  2753. YE=REAL( XCOOR((IOEIL-1)*(idim+1)+2) )
  2754. ZE=REAL( XCOOR((IOEIL-1)*(idim+1)+3) )
  2755. LEGEND(1)=' Retour '
  2756. LEGEND(2)=' Annulation '
  2757. LEGEND(3)=' Position '
  2758.  
  2759. CALL MENU(LEGEND,3,30)
  2760. call trmess('Pour une coupe choisir Position puis la definir')
  2761. CALL TRAFF(ICLE2)
  2762.  
  2763. IF (ICLE2.EQ.0) GOTO 6105
  2764.  
  2765. IF (ICLE2.EQ.1) THEN
  2766. ICOUP=0
  2767. mcou2=0
  2768. mcoup=0
  2769. coupol=-1.
  2770. GOTO 7001
  2771. ENDIF
  2772. call coupno(xmi,xma,ymi,yma,zmi,zma,coupra,coupol)
  2773. if(melemi.ne.0)then
  2774. mcoup=0
  2775. mcou2=0
  2776. meleme=melemi
  2777. endif
  2778. if(melei2.ne.0) melem2=melei2
  2779. icoup=1
  2780. C recherche du min et du max le long de oeil bary
  2781. xb=bary(1)
  2782. yb=bary(2)
  2783. zb=bary(3)
  2784. xm=xb-XE
  2785. ym= yb-YE
  2786. zm= zb-ZE
  2787. oeba=sqrt(xm*xm + ym*ym + zm*zm)
  2788. xm = xm / oeba
  2789. ym=ym/oeba
  2790. zm=zm/oeba
  2791. ipt7=meleme
  2792. ipt3=ipt7
  2793. segact ipt7
  2794. coupma= -1000.*oeba
  2795. coupmi= +1000.*oeba
  2796. do ipa=1,max(1,ipt7.lisous(/1))
  2797. if( ipt7.lisous(/1).ne.0) then
  2798. ipt3=ipt7.lisous(ipa)
  2799. segact ipt3
  2800. endif
  2801. do ipb=1,ipt3.num(/2)
  2802. do ipc=1,ipt3.num(/1)
  2803. iu=ipt3.num(ipc,ipb)*(idim+1)
  2804. xu= real(xcoor(iu-3))
  2805. yu= real(xcoor(iu-2))
  2806. zu= real(xcoor(iu-1))
  2807. dd= xm*(xb-xu) + ym*(yb-yu) +zm*(zb-zu)
  2808. if(coupma.lt.dd ) coupma=dd
  2809. if(coupmi.gt.dd ) coupmi=dd
  2810. enddo
  2811. enddo
  2812. if(ipt7.lisous(/1).ne.0) segdes ipt3
  2813. enddo
  2814. xbn = xb - xm*coupma + xm*coupra*(coupma-coupmi)
  2815. ybn = yb - ym*coupma + ym*coupra*(coupma-coupmi)
  2816. zbn = zb - zm*coupma + zm*coupra*(coupma-coupmi)
  2817. segact,mcoord*MOD
  2818. XCOOR((ICOUP1-1)*(idim+1)+1)=XBn
  2819. XCOOR((ICOUP1-1)*(idim+1)+2)=YBn
  2820. XCOOR((ICOUP1-1)*(idim+1)+3)=ZBn
  2821.  
  2822.  
  2823. if( (abs (XM) + abs(YM)) .ne. 0.) then
  2824. xcoor((icoup2-1)*(idim+1)+1 )= xbn - ym
  2825. xcoor((icoup2-1)*(idim+1)+2 )= ybn + xm
  2826. xcoor((icoup2-1)*(idim+1)+3 )= zbn
  2827. xcoor((icoup3-1)*(idim+1)+1 )= xbn - xm*zm
  2828. xcoor((icoup3-1)*(idim+1)+2 )= ybn - ym*zm
  2829. xcoor((icoup3-1)*(idim+1)+3 )= zbn + xm*xm + ym*ym
  2830. else
  2831. xcoor((icoup2-1)*(idim+1)+1 )= xbn + 1.
  2832. xcoor((icoup2-1)*(idim+1)+2 )= ybn
  2833. xcoor((icoup2-1)*(idim+1)+3 )= zbn
  2834. xcoor((icoup3-1)*(idim+1)+1 )= xbn
  2835. xcoor((icoup3-1)*(idim+1)+2 )= ybn + 1.
  2836. xcoor((icoup3-1)*(idim+1)+3 )= zbn
  2837. endif
  2838. C write(IOIMP,*) ' points definissant la coupe'
  2839. icoy1=(ICOUP1-1)*(idim+1)
  2840. icoy2=(ICOUP2-1)*(idim+1)
  2841. icoy3=(ICOUP3-1)*(idim+1)
  2842. write(IOIMP,fmt='(3(e12.5,2X))')xcoor(icoy1+1),xcoor(icoy1+2)
  2843. $ ,xcoor(icoy1+3)
  2844. write(ioimp,fmt='(3(e12.5,2X))')xcoor(icoy2+1),xcoor(icoy2+2)
  2845. $ ,xcoor(icoy2+3)
  2846. write(ioimp,fmt='(3(e12.5,2X))')xcoor(icoy3+1),xcoor(icoy3+2)
  2847. $ ,xcoor(icoy3+3)
  2848. GOTO 7001
  2849. ENDIF
  2850.  
  2851. IF (ICLE.EQ.9) THEN
  2852. LEGEND(1)= ' Retour '
  2853. LEGEND(2)=' Isovaleurs'
  2854. IF (ZCHAM) THEN
  2855. LEGEND(3)=' (X) Champ'
  2856. ELSE
  2857. LEGEND(3)=' ( ) Champ'
  2858. ENDIF
  2859. IF (ZDATE) THEN
  2860. LEGEND(4)=' (X) Date '
  2861. ELSE
  2862. LEGEND(4)=' ( ) Date '
  2863. ENDIF
  2864. LEGEND(5)=' Fonts >> '
  2865. IF (ICOSC.EQ.1) THEN
  2866. LEGEND(6)='Ecran>> Blanc'
  2867. ELSE IF (ICOSC.EQ.2) THEN
  2868. LEGEND(6)='Ecran>> Noir'