Télécharger prtrac.eso

Retour à la liste

Numérotation des lignes :

  1. C PRTRAC SOURCE FD218221 17/05/12 21:15:06 9433
  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. NVECL=0
  710. C
  711. IF (MDEFOR.EQ.0.AND.MVECTE.EQ.0) GOTO 6000
  712. C---- C'EST UNE DEFORMEE OU UN VECTEUR QUE L'ON VEUT FAIRE -------------
  713.  
  714. C ON ANNULE LES OPTIONS INCOMPATIBLES
  715. IQUALI=0
  716. INUMNO=0
  717. INUMEL=0
  718. IDEFCO=0
  719. IECLAT=0
  720. C IFADES=0 CAS A DISCUTER ????
  721.  
  722. C-----------------------------------------------------------------------
  723. C EXTRAIT DES DEFORMES LE MAILLAGE, LES COORD. POINTS ...
  724. C-----------------------------------------------------------------------
  725. 1234 IF (MDEFOR.NE.0) THEN
  726. CALL CREDEF(KABEL,KABCOR,KABCPR,MDEFOR,LABCO2,sdef )
  727. IF (IMEL3.NE.0) CALL CREDEF(KABEL2,KABCO3,KABCP2,MDEFO1,LABCO3,
  728. > sdef )
  729. ENDIF
  730. IF (MVECTE.NE.0) CALL CREVEC(MELEME,ICPR,KABCOR,LABCO2,MVECTE,0)
  731.  
  732. C-----------------------------------------------------------------------
  733. C CALCUL DU CADRE AVANT DE CYCLER SUR LA SUITE (EN MODIFIANT PROJEC)
  734. C SUR LA DEFORMEE PRINCIPALE
  735. C-----------------------------------------------------------------------
  736.  
  737. C PP + option DIRE
  738. CALL CADRCL(KABCOR,LABCO2,IOEIL,XPROJ,
  739. * 0,XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT,cgrav,diloc,ldire,axez)
  740. Cgoo WRITE(IOIMP,*) 'PRTRAC : XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT=',
  741. Cgoo $ XMINT,YMINT,XMAXT,YMAXT,ZMINT,ZMAXT
  742. C TRACER CARRE FAIT DANS TRINIT SI NECESSAIRE
  743. XMIN=XMINT
  744. XMAX=XMAXT
  745. C XMAX=MAX(XMAXT,XMIN+YMAXT-YMINT,XMIN+ZMAXT-ZMINT)
  746. YMIN=YMINT
  747. YMAX=YMAXT
  748. C YMAX=MAX(YMAXT,YMIN+XMAXT-XMINT,YMIN+ZMAXT-ZMINT)
  749. ZMIN=ZMINT
  750. ZMAX=ZMAXT
  751. C ZMAX=MAX(ZMAXT,ZMIN+XMAXT-XMINT,ZMIN+XMAXT-XMINT)
  752. C Modif des marges
  753. C Ancien :
  754. C XDEC=(XMAX-XMIN)*0.01
  755. C Nouveau :
  756. XDEC=(XMAX-XMIN)*0.1
  757. XMAX=XMAX+XDEC
  758. YMAX=YMAX+XDEC
  759. ZMAX=ZMAX+XDEC
  760. XMIN=XMIN-XDEC
  761. YMIN=YMIN-XDEC
  762. ZMIN=ZMIN-XDEC
  763. IF (IRESU.NE.1) THEN
  764. IF (ZBOIT) THEN
  765. CALL PROJC2(IMBOIT,IOEIL,CGRAV,XBMIN,XBMAX,YBMIN
  766. $ ,YBMAX,ZBMIN,ZBMAX)
  767. XMI=XBMIN
  768. XMA=XBMAX
  769. YMI=YBMIN
  770. YMA=YBMAX
  771. ZMI=ZBMIN
  772. ZMA=ZBMAX
  773. ELSE
  774. XMI=XMIN
  775. XMA=XMAX
  776. YMI=YMIN
  777. YMA=YMAX
  778. ZMI=ZMIN
  779. ZMA=ZMAX
  780. ENDIF
  781. ENDIF
  782. CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET)
  783.  
  784.  
  785. C-----------------------------------------------------------------------
  786. C
  787. C ON BOUCLE SUR LES DEFORMES (OU LES VECTEURS)
  788. C
  789. C-----------------------------------------------------------------------
  790.  
  791. C INITIALISATION de NDEF et NVEC
  792. IF (MDEFOR.NE.0) THEN
  793. SEGACT MDEFOR
  794. NDEF=KABCPR(/1)
  795. C dans le cas isovaleur sur chpoint (ou mchaml) = syntaxe 4,
  796. C 1 seule deformee est utilisee
  797. IF (IRETO3.EQ.1) NDEF=1
  798. IF (IANIM.NE.0) CALL TRANIM(IANIM,NDEF)
  799. ENDIF
  800. IDEFOR=NDEF
  801. KDEFOR=NDEF
  802. IF (MVECTE.NE.0) THEN
  803. SEGACT MVECTE
  804. NVEC=AMPF(/1)
  805. NDEF=1
  806. IDEFOR=NVEC
  807. KDEFOR=0
  808. ENDIF
  809.  
  810. C d'abord on calcule si necessaire le min et max general
  811. vchmin=xsgran
  812. vchmax=-xsgran
  813. if (mdefor.ne.0.and.ichiso.ne.0.and.mlreel.eq.0)
  814. > CALL vchbor(mdefor,1,NDEF,vchmin,vchmax)
  815. if(iimpi.ge.666) write(ioimp,*) 'vchmin,vchmax=',vchmin,vchmax
  816.  
  817. IDEF=0
  818. C>>>> DEBUT DE LA BOUCLE PRINCIPALE >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
  819. 6099 CONTINUE
  820. IDEF=IDEF+1
  821. IF (IDEF.GT.NDEF) GOTO 6100
  822. if(iimpi.ge.666) write(ioimp,*) '------IDEF=',IDEF,' /',NDEF
  823. if(iimpi.ge.666) write(ioimp,*) 'ICHISO,NISO=',ICHISO,NISO
  824.  
  825. c cas animation
  826. IF (IANIM.NE.0) CALL TRIMAG(IDEF)
  827.  
  828. c cas deformee
  829. IF (MDEFOR.NE.0) THEN
  830. VCHC(MIN(NDEFMX,IDEF))=REAL(AMPL(MIN(NDEFMX,IDEF)))
  831. C POUR AFFICHER CORRECTEMENT DEFORME SUR ISOVALEUR
  832. SIAMPL=REAL(AMPL(IDEF))
  833. IF(AMPIMP(IDEF).LT.XSGRAN/2.)SIAMPL=AMPIMP(IDEF)
  834. ICHL(MIN(NDEFMX,IDEF))=JCOUL(MIN(NDEFMX,IDEF))
  835. KSCDEF=JCOUL(MIN(NDEFMX,IDEF))
  836. ENDIF
  837. IF (MDEFOR.NE.0) THEN
  838. ICPR=KABCPR(IDEF)
  839. MELEME=KABEL(IDEF)
  840. XCORD=KABCOR(IDEF)
  841. ITE=XCORD(/2)
  842. cbp IF (MDCHP(IDEF).NE.0) MCHPOI=MDCHP(IDEF)
  843. cbp IF (MDCHEL(IDEF).NE.0) MCHAM=MDCHEL(IDEF)
  844. cbp IF (MDMODE(IDEF).NE.0) IPMO1=MDMODE(IDEF)
  845. c on ne recupere le chpoint d isovaleur de la deformee
  846. c que si pas de chpoint explicitement fourni
  847. IF (IRETO3.EQ.0) THEN
  848. SEGACT MDEFOR
  849. MCHPOI=MDCHP(IDEF)
  850. MCHAM=MDCHEL(IDEF)
  851. IPMO1=MDMODE(IDEF)
  852. ENDIF
  853. ENDIF
  854. if(iimpi.ge.666) write(ioimp,*) 'MCHPOI=',MCHPOI
  855.  
  856. c recup du MELEME et du KABEL si DEFORMES ou de CREVEC si VECTEURS
  857. IPT1=MELEME
  858. if (ite.eq.0) ITE=ICPR(/1)
  859. C GOTO 6010
  860.  
  861. C---- POINT D'ARRIVEE EN L'ABSENCE DE DEFORMES ET DE VECTEURS ----------
  862. 6000 CONTINUE
  863.  
  864. IISO=0
  865. IF (ICHISO.EQ.1) THEN
  866. cbp NISO=1
  867. cbp on introduit IISO
  868. cbp =1 si il y a un champ d isovaleur pour cette ieme deformee
  869. IF(MCHPOI.ne.0.or.mcham.ne.0) IISO=max(1,NISO)
  870. C On ne sait indiquer les isovaleurs que sur une seule deformee
  871. C IF (NDEF.GT.1) CALL ERREUR(283)
  872. IF (IERR.NE.0) GOTO 8900
  873. IF (ISOTYP.GT.0.AND.IDIM.EQ.3) ICACHE=1
  874. ENDIF
  875.  
  876. c les operations suivantes ne doivent etre realisee qu'une seule
  877. c fois, sinon on saute en 6011
  878. IF (IDEF.NE.1) GOTO 6011
  879. if (ipv.eq.0) then
  880.  
  881. C-----------------------------------------------------------------------
  882. C LECTURE MAILLAGE PRINCIPAL (sauf cas deformee et chamelem)
  883. C-----------------------------------------------------------------------
  884. IF (IDEFOR.EQ.0.and.mcham.eq.0) THEN
  885. C SG 2016/11/29 CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  886. IF (IMAILU.GT.NMAXLU) THEN
  887. CALL ERREUR(5)
  888. RETURN
  889. ELSE
  890. MELEME=LMAILU(IMAILU)
  891. IMAILU=IMAILU+1
  892. IF (MELEME.EQ.0) THEN
  893. MOTERR(1:8)='MAILLAGE'
  894. C 37 2 On ne trouve pas d'objet de type %m1:8
  895. CALL ERREUR(37)
  896. ENDIF
  897. ENDIF
  898. IF (IERR.NE.0) GOTO 8900
  899. melsau=meleme
  900. ENDIF
  901. C-----------------------------------------------------------------------
  902. C LECTURE EVENTUELLE D'UN 2ND MAILLAGE
  903. C-----------------------------------------------------------------------
  904. C SG 2016/11/29 CALL LIROBJ('MAILLAGE',MELEM2,0,IRETOU)
  905. IF (IMAILU.GT.NMAXLU) THEN
  906. CALL ERREUR(5)
  907. RETURN
  908. ELSE
  909. MELEM2=LMAILU(IMAILU)
  910. IMAILU=IMAILU+1
  911. IRETOU=1
  912. IF (MELEM2.EQ.0) IRETOU=0
  913. ENDIF
  914. IMEL2=IRETOU
  915. IF (IMEL2.EQ.0.AND.IARET.EQ.1.AND.IDEFOR.EQ.0) GOTO 8900
  916. c IF (MDEFOR.EQ.0) then
  917. C mdefos=mdefor
  918. C MDEFOR=MELEME
  919. c endif
  920. CALL REFUS
  921.  
  922. endif
  923. 6011 CONTINUE
  924.  
  925. C POUR ETRE L'IDENTITE SUR L'OBJET
  926.  
  927. C-----------------------------------------------------------------------
  928. C INTERPOLATION CAS DES ISO
  929. C-----------------------------------------------------------------------
  930.  
  931. cbp IF (NISO.NE.0) THEN
  932. IF (ICHISO.EQ.1) THEN
  933. C ici on rajoute une structure recevant les chamelems
  934. if(VCPCHA.ne.0) segsup,VCPCHA
  935. VCPCHA = 0
  936. if(MCHPOI.ne.0.or.mcham.ne.0) then
  937. SEGINI VCPCHA
  938. cbp cas chpoint fourni (a 1 ou plus composantes), on reinitialise
  939. if (IRETO3.eq.1) then
  940. vchmin=xsgran
  941. vchmax=-vchmin
  942. endif
  943. CALL AVISO(MELEME,MCHPOI,mcham,ipmo1,VCPCHA,VCHC,NISO,NCOUMA,
  944. > VCHMIN,VCHMAX,MLREEL,MCARA,NCOMP,LCOMP,COMPCH,ISOVU)
  945. if(iimpi.ge.666) write(ioimp,*) 'AVISO -> NISO=',NISO
  946. & ,'VCHMIN,VCHMAX=',VCHMIN,VCHMAX
  947. IF (IERR.NE.0) GOTO 8900
  948. endif
  949. ENDIF
  950. if(iimpi.ge.666) write(ioimp,*) 'VCPCHA=',VCPCHA
  951.  
  952. C-----------------------------------------------------------------------
  953. C CAS D'UNE COUPE
  954. C-----------------------------------------------------------------------
  955.  
  956. IF (ICOUP.EQ.1) THEN
  957. if (melemi.eq.0) melemi=meleme
  958. if (melei2.eq.0) melei2=melem2
  959. C write(6 ,*) ' on doit faire une coupe '
  960. IF (IDEFOR.EQ.0.AND.MVECTE.EQ.0) THEN
  961. CALL CRCOUP(IOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCPCHA,
  962. * MELEM2,MCOU2,mcham,isect)
  963. ELSE
  964. KABC=KABCOR(IDEF)
  965. XCORD=KABC
  966. SEGACT XCORD
  967. NBCTS=XCORD(/2)
  968. ITE=NBCTS
  969. C INITIALISATION DE IVU (UN ELEMENT PAR POINT)
  970. C IVU=1 POINT VU (EN CAS DE COUPE )
  971. C IVU<>1 POINT PAS VU
  972. SEGINI IVU
  973. DO 5000 I=1,ITE
  974. IVU(I)=1
  975. 5000 CONTINUE
  976. CALL CRCOU2(IOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCPCHA,
  977. * KABC,ICPR,MELEM2,MCOU2,ITE,IVU,mcham,isect)
  978. ENDIF
  979. ENDIF
  980.  
  981. C 3001 CONTINUE
  982.  
  983. C -ON SAUTE CETTE PARTIE SI DEFORMEE OU VECTEURS
  984. IF (IDEFOR.NE.0.OR.MVECTE.NE.0) GOTO 6010
  985. C SI MCOUP=0 DECRIT LA VISIBILITE DU DERNIER COMPOSANT DE MELEME
  986. SEGINI ICPR
  987. DO 3010 I=1,ICPR(/1)
  988. ICPR(I)=0
  989. 3010 CONTINUE
  990. ITE=0
  991. SEGACT MELEME
  992. IPT1=MELEME
  993. DO 3003 I=1,MAX(1,LISOUS(/1))
  994. IF (LISOUS(/1).NE.0) THEN
  995. IPT1=LISOUS(I)
  996. ENDIF
  997. SEGACT IPT1
  998. DO 3005 J=1,IPT1.NUM(/1)
  999. DO 30051 K=1,IPT1.NUM(/2)
  1000. IPOIT=IPT1.NUM(J,K)
  1001. IF (ICPR(IPOIT).NE.0) GOTO 30051
  1002. ITE=ITE+1
  1003. ICPR(IPOIT)=ITE
  1004. 30051 CONTINUE
  1005. 3005 CONTINUE
  1006. 3003 CONTINUE
  1007. C on complete ICPR avec le 2eme maillage pour que celui ci soit toujours trace
  1008. if (imel2.ne.0) then
  1009. ipt2=melem2
  1010. SEGACT ipt2
  1011. IPT1=ipt2
  1012. DO 3013 I=1,MAX(1,ipt2.LISOUS(/1))
  1013. IF (ipt2.LISOUS(/1).NE.0) THEN
  1014. IPT1=ipt2.LISOUS(I)
  1015. ENDIF
  1016. SEGACT IPT1
  1017. DO 3015 J=1,IPT1.NUM(/1)
  1018. DO 30151 K=1,IPT1.NUM(/2)
  1019. IPOIT=IPT1.NUM(J,K)
  1020. IF (ICPR(IPOIT).NE.0) GOTO 30151
  1021. ITE=ITE+1
  1022. ICPR(IPOIT)=ITE
  1023. 30151 CONTINUE
  1024. 3015 CONTINUE
  1025. 3013 CONTINUE
  1026. endif
  1027. NBCTS=ITE
  1028. DO 5011 I=NBPTS+1,XCOOR(/1)/(IDIM+1)
  1029. IF (ICPR(I).EQ.0) THEN
  1030. ITE=ITE+1
  1031. ICPR(I)=ITE
  1032. ENDIF
  1033. 5011 CONTINUE
  1034. 6010 CONTINUE
  1035. C -FIN DE LA PARTIE SAUTEE SI DEFORMEE OU VECTEURS
  1036. C
  1037. C EN CAS DE TRACE ECLATE ON PROCEDE DIFFEREMMENT
  1038. IF (IECLAT.EQ.1) GOTO 4200
  1039.  
  1040. C ITE EST LE NOMBRE DE POINTS A TRACER ICPR LE TABLEAU
  1041. C ON VA MAINTENANT INITIALISER ET REMPLIR LE TABLEAU DES CONNECTIONS
  1042. IMELIN=MELEME
  1043. MCOUIN=MCOUP
  1044.  
  1045. C----------------------------------------------------------
  1046. C LE 2ND MAILLAGE DEVIENT MAILLAGE PRINCIPAL - LES POINTS VUS
  1047. C ONT ETE CALCULES SUR LE 1ER MAILLAGE - (IDEM DEFO)
  1048. C----------------------------------------------------------
  1049. IF (IMEL2.NE.0) THEN
  1050. MELEM3=MELEME
  1051. MELEME=MELEM2
  1052. ENDIF
  1053. IF (IMEL2.NE.0) MCOUP =MCOU2
  1054. IF (IMEL3.NE.0) THEN
  1055. MELEM3=KABEL(IDEF)
  1056. MELEME=KABEL2(IDEF)
  1057. C KABCOR=KABCOR(IDEF)
  1058. ICPR=KABCPR(IDEF)
  1059. C LABCO2=LABCO3
  1060. ENDIF
  1061. IPT1=MELEME
  1062. SEGACT MELEME
  1063.  
  1064. C----------------------------------------------------------
  1065. C REALISATION DU TABLEAU DES CONNECTIONS
  1066. C KON(3,VOISIN,NOEUD) :
  1067. C KON(1,V,N)=Numero DU V-IEME NOEUD RELIE PAR UN SEGMENT AU NOEUD N
  1068. C KON(2,V,N)=COULEUR DU V-IEME NOEUD RELIE PAR UN SEGMENT A N
  1069. C Il peut y avoir plusieurs couleurs collationnees en binaire
  1070. C par ajout de puissances de 2
  1071. C KON(3,V,N)=0 si codage couleur direct, 1 si codage binaire
  1072. C RMQ: SI N=NBCONR, RENVOI SUR LISTE DE NOEUDS VOISINS
  1073. C----------------------------------------------------------
  1074. C Pour permettre les isovaleurss sur les poutres, on exclue de ce tableau
  1075. C ce qui vient des SEG2 et SEG3 si on est en isovaleur
  1076. C
  1077. NBCON =9
  1078. NBCONR=NBCON-1
  1079. NMAX =(12*ITE)/NBCON+200
  1080. SEGINI KON
  1081. C MISE A ZERO DU TABLEAU KON
  1082. DO I=1,NMAX
  1083. DO J=1,NBCON
  1084. KON(1,J,I)=0
  1085. KON(2,J,I)=0
  1086. KON(3,J,I)=0
  1087. ENDDO
  1088. ENDDO
  1089.  
  1090. C FABRICATION DU TABLEAU DES CONNECTIONS
  1091. ICHAIN=ITE
  1092. COUPE=.FALSE.
  1093. C Boucle sur les Partitions
  1094. DO 222 IO=1,MAX(1,LISOUS(/1))
  1095. IF (LISOUS(/1).NE.0) THEN
  1096. COUPE=.FALSE.
  1097. IF (IO.EQ.LISOUS(/1).AND.MCOUP.NE.0) COUPE=.TRUE.
  1098. IPT1=LISOUS(IO)
  1099. ENDIF
  1100. SEGACT IPT1
  1101. K=IPT1.ITYPEL
  1102. C PRISE EN COMPTE DES BLOCAGES
  1103. IF (K.EQ.22) BLOCAG=.TRUE.
  1104. IF (K.EQ.1) CROIX =.TRUE.
  1105. C poutres+iso on saute
  1106. if(iimpi.ge.666) write(ioimp,*)
  1107. & 'avant goto 222 : ICHISO,NISO,MCHPOI=',ICHISO,NISO,MCHPOI
  1108. cbp if ((k.eq.2.or.k.eq.3).and.niso.ne.0.and.
  1109. if ((k.eq.2.or.k.eq.3).and.IISO.NE.0.and.
  1110. > meleme.ne.melem2) goto 222
  1111. C
  1112. if(iimpi.ge.666) write(ioimp,*)
  1113. & 'remplissage de KON depui IPT1=',IPT1
  1114. IDEP=LPT(K)
  1115. IFIN1=IDEP+2*LPL(K)-2
  1116. IFIN2=IFIN1
  1117. IF (LPL(K).EQ.0) THEN
  1118. IF (LPT(K).EQ.0)THEN
  1119. GOTO 2225
  1120. ELSE
  1121. C Polygone
  1122. IFIN1=IDEP+2*IPT1.NUM(/1)-2
  1123. IFIN2=IFIN1 - 2
  1124. ENDIF
  1125. ENDIF
  1126.  
  1127. IF (IDEFOR.NE.0.AND.MDEFOR.NE.0) SEGACT MDEFOR
  1128. C Boucle sur les elements de la partition
  1129. DO 223 I=1,IPT1.NUM(/2)
  1130. IF (IDEFOR.EQ.0.OR.MVECTE.NE.0.OR.IANIM.NE.0) THEN
  1131. KSCOLI=IPT1.ICOLOR(I)
  1132. C IF (KSCOLI.EQ.0) KSCOLI=IDCOUL
  1133. ELSE
  1134. KSCOLI=KSCDEF
  1135. C+PP couleur par defaut pour les deformees = celle du maillage
  1136. IF (KSCOLI.EQ.0) KSCOLI=IPT1.ICOLOR(I)
  1137. C+PP
  1138. C IF (KSCOLI.EQ.0) KSCOLI=IDCOUL
  1139. ENDIF
  1140. if(iimpi.ge.666) write(ioimp,*) 'KSCOLI=',KSCOLI
  1141. IS=1
  1142. DO 2 J=IDEP,IFIN1,2
  1143. IF (J.LE.IFIN2) THEN
  1144. N1=ICPR(IPT1.NUM(KSEGM(J),I))
  1145. N2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  1146. ELSE
  1147. C Polygone
  1148. N1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  1149. N2=ICPR(IPT1.NUM(KSEGM(1),I))
  1150. ENDIF
  1151. IF (COUPE) THEN
  1152. C NE FONCTIONNE QUE SUR DES TRI3
  1153. IS=IS*2
  1154. IF (MOD((2*MCOUP(I))/IS,2).EQ.0) GOTO 2
  1155. ENDIF
  1156. NI=N1
  1157. NJ=N2
  1158. IF (N1*N2.EQ.0) GOTO 8
  1159. C Attribution de la couleur au segment correspondant dans KON :
  1160. IPO=0
  1161. 9 CONTINUE
  1162. KSCOL1=KSCOLI
  1163. NII=NI
  1164. 7 DO 4 K=1,NBCONR
  1165. IF (KON(1,K,NI).GT.NJ) GOTO 4
  1166. IF (KON(1,K,NI).LT.NJ) THEN
  1167. KSAUV1=NJ
  1168. KSCOL1=KSCOLI
  1169. KSCOD1=0
  1170. GOTO 5
  1171. ENDIF
  1172.  
  1173. C recherche si KSCOL1 fait partie des couleurs du segment,
  1174. C si oui (JJ=1), deje traite
  1175. C sinon (JJ=0), on l'ajoute a la liste de couleurs
  1176. C et on met a jour celle des segments eventuellement confondus
  1177. JJ=0
  1178. C IF (KSCOL1.EQ.0) KSCOL1=IDCOUL
  1179. CPM IF (KON(2,K,NI).LT.300) KON(2,K,NI)=
  1180. CPM $ 300+(2**(KON(2,K,NI)-1))
  1181. IF (KON(3,K,NI).EQ.0) THEN
  1182. C Passage en binaire si pas deja fait
  1183. KON(3,K,NI)=1
  1184. IK=KON(2,K,NI)
  1185. KON(2,K,NI)=IPUIS2(IK)
  1186. C Il n'y a qu'une seule couleur de codee, facile a tester
  1187. IF (IK.EQ.KSCOL1) JJ=1
  1188. ELSE
  1189. C potentiellement plusieurs couleurs codees, a tester
  1190. CPM ICAL=KON(2,K,NI)-300
  1191. ICAL=KON(2,K,NI)
  1192. CPM (NBCOUL-1) au lieu de 7
  1193. DO II=(NBCOUL-1),KSCOL1,-1
  1194. IF (IPUIS2(II).LE.ICAL) THEN
  1195. IF (II.EQ.KSCOL1) THEN
  1196. JJ=1
  1197. ELSE
  1198. ICAL=ICAL-IPUIS2(II)
  1199. ENDIF
  1200. ENDIF
  1201. ENDDO
  1202. ENDIF
  1203.  
  1204. C Si cette couleur existe, le segment a deja ete traite
  1205. IF (JJ.EQ.1) GOTO 2
  1206.  
  1207. C sinon on ajoute la couleur a la liste binaire de couleurs du segment
  1208. KON(2,K,NI)=KON(2,K,NI)+IPUIS2(KSCOL1)
  1209.  
  1210. C ainsi qu'aux segments confondus eventuels
  1211. 1111 CONTINUE
  1212. DO II=1,NBCONR
  1213. IF (KON(1,II,NJ).EQ.NII) THEN
  1214. KON(2,II,NJ)=KON(2,K,NI)
  1215. KON(3,II,NJ)=KON(3,K,NI)
  1216. GOTO 1113
  1217. ENDIF
  1218. ENDDO
  1219. IF (KON(1,NBCON,NJ).NE.0) THEN
  1220. NJ=KON(1,NBCON,NJ)
  1221. GOTO 1111
  1222. ENDIF
  1223. 1113 CONTINUE
  1224. GOTO 2
  1225. 4 CONTINUE
  1226.  
  1227. C on passe au noeud suivant dans la chaine,
  1228. C ou on l'incremente et on la met a jour si on est arrive au bout
  1229. IF (KON(1,NBCON,NI).NE.0) THEN
  1230. NI=KON(1,NBCON,NI)
  1231. GOTO 7
  1232. ENDIF
  1233. KSAUV1=NJ
  1234. KSCOL1=KSCOLI
  1235. KSCOD1=1
  1236. 301 ICHAIN=ICHAIN+1
  1237. IF (ICHAIN.EQ.NMAX) THEN
  1238. NMAX=NMAX+1000
  1239. SEGADJ KON
  1240. C WRITE (IOIMP,*) 'PRTRAC: KON agrandi'
  1241. ENDIF
  1242. KON(1,NBCON,NI)=ICHAIN
  1243. K=1
  1244. NI=ICHAIN
  1245.  
  1246. C On insere la nouvelle connexion NJ a la place de la
  1247. C connexion actuelle, et on decale le reste d'un cran
  1248. 5 CONTINUE
  1249. KSAUV=KON(1,K,NI)
  1250. KSCOL=KON(2,K,NI)
  1251. KSCOD=KON(3,K,NI)
  1252. C IF (KSCOL1.EQ.0) KSCOL1=IDCOUL
  1253. KON(1,K,NI)=KSAUV1
  1254. KON(2,K,NI)=KSCOL1
  1255. KON(3,K,NI)=KSCOD1
  1256. KSAUV1=KSAUV
  1257. KSCOL1=KSCOL
  1258. KSCOD1=KSCOD
  1259. IF (KSAUV.EQ.0) GOTO 3
  1260. KDEP=K+1
  1261. IF (KDEP.EQ.NBCON) GOTO 302
  1262. 303 CONTINUE
  1263. DO KHE=KDEP,NBCONR
  1264. KSAUV=KON(1,KHE,NI)
  1265. KSCOL=KON(2,KHE,NI)
  1266. KSCOD=KON(3,KHE,NI)
  1267. C IF (KSCOL1.EQ.0) KSCOL1=IDCOUL
  1268. KON(1,KHE,NI)=KSAUV1
  1269. KON(2,KHE,NI)=KSCOL1
  1270. KON(3,KHE,NI)=KSCOD1
  1271. IF (KSAUV.EQ.0) GOTO 3
  1272. KSAUV1=KSAUV
  1273. KSCOL1=KSCOL
  1274. KSCOD1=KSCOD
  1275. ENDDO
  1276. 302 CONTINUE
  1277. IF (KON(1,NBCON,NI).EQ.0) GOTO 301
  1278. NI=KON(1,NBCON,NI)
  1279. KDEP=1
  1280. GOTO 303
  1281. 3 IF (NJ.NE.N2.OR.IPO.EQ.1) GOTO 2
  1282. NI=N2
  1283. NJ=N1
  1284. IPO=1
  1285. GOTO 9
  1286. 2 CONTINUE
  1287. 223 CONTINUE
  1288. 2225 CONTINUE
  1289. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1290. 222 CONTINUE
  1291. GOTO 10
  1292. C Operation malvenue. Resultat douteux
  1293. 8 CALL ERREUR(23)
  1294.  
  1295. 10 CONTINUE
  1296.  
  1297. SEGDES MELEME
  1298. CTC IF (MCOU2.NE.0) THEN
  1299. C NETTOYAGE APRES COUPE
  1300. C SEGSUP MCOUP
  1301. C SEGACT MELEME
  1302. C DO 8802 IO=1,LISOUS(/1)
  1303. C IPT1=LISOUS(IO)
  1304. C SEGSUP IPT1
  1305. C 8802 CONTINUE
  1306. C SEGSUP MELEME
  1307. C ENDIF
  1308. MELEME=IMELIN
  1309. MCOUP =MCOUIN
  1310. C GESTION DU TABLEAU ICPR(COMPTEUR DE COULEUR)
  1311. C ITEST(II) = 1 si la couleur appartient a la liste du point, 0 sinon
  1312. C (= conversion de KON(2,I,J) en tableau)
  1313. C ICHC(I) : nb de segments sur lesquels apparait la couleur I
  1314. C On ramene, si code en binaire, KON(2,.,.) dans l'intervalle
  1315. C [0;NBCOUL-1] en melangeant eventuellement les couleurs des
  1316. C segments confondus
  1317. DO 310 I=1,NBCONR
  1318. DO 3101 J=1,KON(/3)
  1319. CPM on ecrit IK au lieu de KON(2,I,J) pour economiser l'acces memoire
  1320. IK=KON(2,I,J)
  1321. IF (IK.NE.0) THEN
  1322. CPM IF (IK.LE.9) THEN
  1323. IF (KON(3,I,J).EQ.0) THEN
  1324. C KON(2,.,.) est deja code dans l'intervalle [0;NBCOUL-1]
  1325. C soit que ce segment est seul, soit qu'il a deja ete rencontre 1 fois
  1326. ICHC(IK)=ICHC(IK)+1
  1327. ELSE
  1328. C cas ou KON est code en puissances de 2 dans [1;2**(NBCOUL-1)]
  1329. CPM NBCOUL-1 au lieu de 7
  1330. C tablage des couleurs possibles. IK finit a 0
  1331. DO II=1,(NBCOUL-1)
  1332. ITEST(II)=0
  1333. ENDDO
  1334. CPM NBCOUL-1 au lieu de 7
  1335. DO II=(NBCOUL-1),1,-1
  1336. IF (IPUIS2(II).LE.IK) THEN
  1337. IK=IK-IPUIS2(II)
  1338. ITEST(II)=1
  1339. ENDIF
  1340. ENDDO
  1341.  
  1342. C Couleur finale du segment a tracer
  1343. IF (IDEFCO.EQ.1.AND.ITEST(IICOL).EQ.1) THEN
  1344. C Le segment est eligible
  1345. IK=IICOL
  1346. ELSE
  1347. CPM NBCOUL-1 au lieu de 7
  1348. IK=0
  1349. DO II=1,NBCOUL-1
  1350. IF (ITEST(II).EQ.1) THEN
  1351. C si plusieurs couleurs, on les melange
  1352. IF (IK.EQ.0) THEN
  1353. IK=II
  1354. ELSE
  1355. IK=ITABM(IK,II)
  1356. ENDIF
  1357. ENDIF
  1358. ENDDO
  1359. ENDIF
  1360. KON(2,I,J)=IK
  1361. KON(3,I,J)=0
  1362. ICHC(IK)=ICHC(IK)+1
  1363. ENDIF
  1364. ENDIF
  1365. 3101 CONTINUE
  1366. 310 CONTINUE
  1367. SEGDES KON
  1368. IF (IRESU.EQ.6) GOTO 4999
  1369.  
  1370. C POINT D'ARRIVEE SI ECLATE
  1371. 4200 CONTINUE
  1372. segact icpr
  1373. SEGINI XPROJ
  1374. IF (IDEFOR.NE.0) GOTO 6030
  1375. C IF (IDEFOR.NE.0.OR.MVECTE.NE.0) GOTO 6030 A VOIR PV
  1376. C LA TROISIEME COORDONNEE PROJETEE EST LA DISTANCE A L'OEIL
  1377. CALL PROJEC(ICPR,XPROJ,IOEIL,CGRAV,axez)
  1378. SEGDES ICPR
  1379. IF (ZBOIT) THEN
  1380. CALL PROJC2(IMBOIT,IOEIL,CGRAV,XBMIN,XBMAX,YBMIN
  1381. $ ,YBMAX,ZBMIN,ZBMAX)
  1382. ENDIF
  1383. C
  1384. XMIN=1E30
  1385. XMAX=-XMIN
  1386. YMIN=XMIN
  1387. YMAX=XMAX
  1388. ZMIN=XMIN
  1389. ZMAX=XMAX
  1390. DO I=1,ITE
  1391. XMIN=MIN(XMIN,XPROJ(1,I))
  1392. XMAX=MAX(XMAX,XPROJ(1,I))
  1393. YMIN=MIN(YMIN,XPROJ(2,I))
  1394. YMAX=MAX(YMAX,XPROJ(2,I))
  1395. ZMIN=MIN(ZMIN,XPROJ(3,I))
  1396. ZMAX=MAX(ZMAX,XPROJ(3,I))
  1397. ENDDO
  1398. C
  1399. XDEC=XMAX-XMIN
  1400. YDEC=YMAX-YMIN
  1401. ZDEC=ZMAX-ZMIN
  1402. C Modif des marges
  1403. C Nouveau :
  1404. DDEC=MAX(XDEC,YDEC,ZDEC)*0.1
  1405. C MODIF JCARDO 28/02/2012 : DDEC vaut maintenant XSZPRE au minimum
  1406. C (evite des erreurs de cancellation)
  1407. DDEC=MAX(DDEC,REAL(xszpre))
  1408. C DDEC=MAX(DDEC,xspeti)
  1409. XMAX=XMAX+DDEC
  1410. XMIN=XMIN-DDEC
  1411. YMIN=YMIN-DDEC
  1412. YMAX=YMAX+DDEC
  1413. ZMIN=ZMIN-DDEC
  1414. ZMAX=ZMAX+DDEC
  1415. C Zoom ou dezoome
  1416. IF (ZBOIT) THEN
  1417. XMI=XBMIN
  1418. XMA=XBMAX
  1419. YMI=YBMIN
  1420. YMA=YBMAX
  1421. ZMI=ZBMIN
  1422. ZMA=ZBMAX
  1423. ELSE
  1424. XMI=XMIN
  1425. YMI=YMIN
  1426. ZMI=ZMIN
  1427. XMA=XMAX
  1428. YMA=YMAX
  1429. ZMA=ZMAX
  1430. ENDIF
  1431. Cgoo CALL DFENET(XMIN,XMAX,YMIN,YMAX,ZMIN,ZMAX,X1,X2,Y1,Y2,FENET)
  1432. CALL DFENET(XMI,XMA,YMI,YMA,ZMI,ZMA,X1,X2,Y1,Y2,FENET)
  1433. GOTO 6040
  1434. 6030 CONTINUE
  1435. C FAIRE ICI LA PROJECTION DE LA DEFORMEE
  1436. C PP + option DIRE
  1437. CALL CADRCL(KABCOR,LABCO2,IOEIL,XPROJ,
  1438. * IDEF,XMIN,YMIN,XMAX,YMAX,ZMIN,ZMAX,cgrav,diloc,ldire,axez)
  1439. 6040 CONTINUE
  1440. C
  1441. C
  1442. C BERTIN: AFFICHAGE DE LA DATE
  1443. IF (ZDATE) THEN
  1444. CALL GIBDAT(JOUR,MOIS,IANNEE)
  1445. iannee=mod(iannee,100)
  1446. C*TC TIME=FDATE()
  1447. BUFFER(1:22)=' / /20 '
  1448. WRITE (BUFFER(4:5),FMT='(I2)') JOUR
  1449. WRITE (BUFFER(7:8),FMT='(I2)') MOIS
  1450. WRITE (BUFFER(12:13),FMT='(I2)') IANNEE
  1451. C*TC WRITE (BUFFER(15:22),FMT='(A8)') TIME(12:20)
  1452. C CALL TRBOX(0.8,0.8)
  1453. READ(BUFFER(1:22),'(A26)') BUFFER
  1454. C CALL TRBOX(1./0.8,1./0.8)
  1455. ENDIF
  1456. C BERTIN: FIN AFFICHAGE DE LA DATE
  1457.  
  1458. C----------------------------------------------------------
  1459. C INITIALISATION DE IVU SI NON FAIT
  1460. C IVU=1 PT VU
  1461. C IVU<>1 PT PAS VU
  1462. C----------------------------------------------------------
  1463. 4999 CONTINUE
  1464. IF (IVU.EQ.0) THEN
  1465. SEGINI IVU
  1466. DO 4997 I=1,ITE
  1467. IVU(I)=1
  1468. 4997 CONTINUE
  1469. ENDIF
  1470. C METTRE NON CACHABLE LES POINTS DU PLAN DE COUPE
  1471. SEGADJ IVU
  1472. C IF (ICACHE.NE.0.AND.NBCTS.NE.0) THEN CORRECTION PV
  1473. IF (NBCTS.NE.0) THEN
  1474. DO 5010 I=NBCTS+1,ITE
  1475. IVU(I)=2
  1476. 5010 CONTINUE
  1477. ENDIF
  1478. C
  1479. CPM NBCOUL-1 au lieu de 8
  1480. DO I=1,NBCOUL-1
  1481. ICHCS(I)=ICHC(I)
  1482. ENDDO
  1483. C cacher en soft si pas opengl
  1484. if (iogra.ne.6) then
  1485. C DEBUT MODIF
  1486. IF (ICACHE.NE.0) THEN
  1487. IF (IARET.EQ.0) THEN
  1488. CALL TIRET3(XPROJ,MELEME,ICPR,XMIN,XMAX,YMIN,YMAX,
  1489. . IVU,NELEM,TMIN,TMAX,MCOUP)
  1490. ELSE
  1491.  
  1492. CALL TIRET3(XPROJ,MELEM3,ICPR,XMIN,XMAX,YMIN,YMAX,
  1493. . IVU,NELEM,TMI,TMAX,MCOUP)
  1494. ENDIF
  1495. ENDIF
  1496. C FIN MODIF
  1497. endif
  1498.  
  1499. C------------------------------------------------------------
  1500. C CAS DU TRACE PAR FACE APPEL AU SOUS-PROGRAM FACED
  1501. C POUR REMPLIR LES FACES
  1502. C------------------------------------------------------------
  1503. IF (IECLAT.NE.1) THEN
  1504. if(iimpi.ge.666) then
  1505. segact,KON
  1506. write(ioimp,*) 'KON(1,:,1)=',(KON(1,iou,1),iou=1,3)
  1507. write(ioimp,*) 'KON(2,:,1)=',(KON(2,iou,1),iou=1,3)
  1508. write(ioimp,*) 'KON(3,:,1)=',(KON(3,iou,1),iou=1,3)
  1509. write(ioimp,*) 'KON(1,:,2)=',(KON(1,iou,2),iou=1,3)
  1510. write(ioimp,*) 'KON(2,:,2)=',(KON(2,iou,2),iou=1,3)
  1511. write(ioimp,*) 'KON(3,:,2)=',(KON(3,iou,2),iou=1,3)
  1512. write(ioimp,*) 'KON(1,:,3)=',(KON(1,iou,3),iou=1,3)
  1513. write(ioimp,*) 'KON(2,:,3)=',(KON(2,iou,3),iou=1,3)
  1514. write(ioimp,*) 'KON(3,:,3)=',(KON(3,iou,3),iou=1,3)
  1515. endif
  1516. if(iimpi.ge.666) write(ioimp,*) 'appel a FACED',IFADES
  1517. IF (IFADES.EQ.1) THEN
  1518. CALL FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,1)
  1519. ELSEIF (IFADES.EQ.0.AND.IOGRA.EQ.6.AND.ICACHE.EQ.1) THEN
  1520. C TRACe DES ELEMENTS EN EFFACEMENT
  1521. CALL FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,0)
  1522. ENDIF
  1523. ENDIF
  1524. IF (IERR.NE.0) GOTO 8900
  1525.  
  1526. C------------------------------------------------------------
  1527. C
  1528. C CAS OU ON VEUT TRACER LES ISOVALEURS D UN OBJET DE TYPE CHAMPOINT
  1529. C
  1530. C------------------------------------------------------------
  1531. cbp IF (NISO.NE.0) THEN
  1532. IF (VCPCHA.NE.0) THEN
  1533. C signaler le nombre d'iso
  1534. CALL FVALIS(0,IRESU,NHAUT,NISO)
  1535. PTI=XMAX-XMIN
  1536. if(iimpi.ge.666) write(ioimp,*) 'apel a ATISO'
  1537. CALL ATISO(MELEME,ICPR,XPROJ,VCPCHA,VCHC,IVU,PTI,NISO,MCOUP,
  1538. > mcham)
  1539. ENDIF
  1540. C
  1541. C 6080 CONTINUE
  1542. IF (IERR.NE.0) RETURN
  1543. IF (ICACHE.EQ.1) THEN
  1544. LTSEGS=1000
  1545. SEGINI NTSEG
  1546. LTSEG=0
  1547. endif
  1548. C 5001 CONTINUE
  1549. C IF (IECLAT.EQ.1.OR.IFADES.EQ.1) GOTO 4201 PV JUIN 86
  1550. IF (IECLAT.EQ.1) GOTO 4201
  1551. C TRACE DES SEGMENTS D'UNE COULEUR EN LES GROUPANT EN UNE LIGNE
  1552. if(iimpi.ge.666) write(ioimp,*) 'TRACE DES SEGMENTS DUNE COULEUR'
  1553. SEGACT KON*MOD
  1554. C PM NBCOUL-1 au lieu de 8
  1555. icoul=-3
  1556. DO 70 LI=0,NBCOUL-1
  1557. IF (IDEFCO.EQ.1 .AND. LI.NE.IICOL) GOTO 70
  1558. C SI ISOVALEUR ET REMPLISSAGE COULEUR EFFACEMENT
  1559. C MODIF JCARDO 8/12/2011 : rajout condition LI=0
  1560. C => on force NOIR seulement si COUL=DEFA
  1561. C MODIF JCARDO 28/02/2012 : rajout condition IMEL2=0 (eventuellement)
  1562. C => on force NOIR seulement s'il y a un
  1563. C seul objet MAILLAGE
  1564. C IF (NISO.NE.0.AND.ISOTYP.GT.0) CALL CHCOUL(IDNOIR)
  1565. C IF (LI.EQ.0.AND.NISO.NE.0.AND.ISOTYP.GT.0)
  1566. cbp IF ((IMEL2.EQ.0.OR.LI.EQ.0).AND.NISO.NE.0.AND.ISOTYP.GT.0)
  1567. IF ((IMEL2.EQ.0.OR.LI.EQ.0).AND.IISO.NE.0.AND.ISOTYP.GT.0) then
  1568. kcoul=idnoir
  1569. ELSE
  1570. C PP kcoul=LI
  1571. C+PP FACE avec trait blanc
  1572. IF (LBLANC) THEN
  1573. kcoul=0
  1574. ELSE
  1575. kcoul=LI
  1576. ENDIF
  1577. C+PP
  1578. ENDIF
  1579. KAUX=1
  1580. 23 K=KAUX
  1581. IF (IVU(KAUX).LE.0) GOTO 40
  1582. KAUXR=KAUX
  1583. 41 CONTINUE
  1584. DO 19 KL=1,NBCONR
  1585. ITRA=KON(1,KL,K)
  1586. IF (ITRA.LT.0) GOTO 19
  1587. IF (ITRA.EQ.0) GOTO 40
  1588. IF (KON(2,KL,K).NE.LI) GOTO 19
  1589. IF (IVU(ITRA).GE.1) GOTO 21
  1590. 19 CONTINUE
  1591. K=KON(1,NBCON,K)
  1592. IF (K.NE.0) GOTO 41
  1593. 40 KAUX=KAUX+1
  1594. IF (KAUX.GE.ITE+1) GOTO 27
  1595. GOTO 23
  1596. 21 CONTINUE
  1597. IF (ITR.GT.1) THEN
  1598. if (kcoul.ne.icoul) then
  1599. call chcoul(kcoul)
  1600. icoul=kcoul
  1601. endif
  1602. CALL POLRL(ITR,XTR,YTR,ZTR)
  1603. ENDIF
  1604. ITR=1
  1605. XTR(ITR)=XPROJ(1,KAUXR)
  1606. YTR(ITR)=XPROJ(2,KAUXR)
  1607. ZTR(ITR)=XPROJ(3,KAUXR)
  1608. KPRESS=KAUXR
  1609. GOTO 25
  1610. 24 KL=1
  1611. 25 DO 22 L=KL,NBCONR
  1612. M=KON(1,L,K)
  1613. IF (M.EQ.0) GOTO 23
  1614. IF (M.LT.0) GOTO 22
  1615. IF (KON(2,L,K).NE.LI) GOTO 22
  1616. IF (IVU(M).LE.0) GOTO 22
  1617. GOTO 28
  1618. 22 CONTINUE
  1619. K=KON(1,NBCON,K)
  1620. IF (K.EQ.0) GOTO 23
  1621. GOTO 24
  1622. 28 CONTINUE
  1623. ITR=ITR+1
  1624. XTR(ITR)=XPROJ(1,M)
  1625. YTR(ITR)=XPROJ(2,M)
  1626. ZTR(ITR)=XPROJ(3,M)
  1627. IF (ITR.EQ.40) THEN
  1628. if (kcoul.ne.icoul) then
  1629. call chcoul(kcoul)
  1630. icoul=kcoul
  1631. endif
  1632. CALL POLRL(ITR,XTR,YTR,ZTR)
  1633. XTR(1)=XTR(ITR)
  1634. YTR(1)=YTR(ITR)
  1635. ZTR(1)=ZTR(ITR)
  1636. ITR=1
  1637. ENDIF
  1638. KON(1,L,K)=-KON(1,L,K)
  1639. M1=M
  1640. 42 DO 43 L=1,NBCONR
  1641. IF (KON(1,L,M1).EQ.0) GOTO 45
  1642. IF (KON(1,L,M1).EQ.KPRESS) GOTO 44
  1643. 43 CONTINUE
  1644. M1=KON(1,NBCON,M1)
  1645. IF (M1.EQ.0) GOTO 45
  1646. GOTO 42
  1647. 44 KON(1,L,M1)=-KON(1,L,M1)
  1648. 45 KPRESS=M
  1649. GOTO 24
  1650. 27 CONTINUE
  1651. IF (ITR.NE.1) THEN
  1652. if (kcoul.ne.icoul) then
  1653. call chcoul(kcoul)
  1654. icoul=kcoul
  1655. endif
  1656. CALL POLRL(ITR,XTR,YTR,ZTR)
  1657. ENDIF
  1658. ITR=0
  1659. 70 CONTINUE
  1660. IF (ICACHE.EQ.0) GOTO 5002
  1661.  
  1662. C----------------------------------------------------------
  1663. C ON REMPLIT NTSEG AVEC LES SEGMENTS EN PARTIE VUS
  1664. C (OPTION CACHE)
  1665. C----------------------------------------------------------
  1666. DO 5003 K=1,ITE
  1667. IF (IVU(K).LE.0) GOTO 5003
  1668. KK=K
  1669. 5005 CONTINUE
  1670. DO 5004 KL=1,NBCONR
  1671. ITRA=KON(1,KL,KK)
  1672. IF (ITRA.LT.0) GOTO 5004
  1673. IF (ITRA.EQ.0) GOTO 5003
  1674. IF (LTSEGS-LTSEG.LT.10) THEN
  1675. LTSEGS=LTSEGS+1000
  1676. SEGADJ NTSEG
  1677. ENDIF
  1678. NTSEG(LTSEG+1)=K
  1679. NTSEG(LTSEG+2)=ITRA
  1680. C MODIF JCARDO 28/02/2012 : rajout conditions LICLR=0 (+ eventuellement IMEL2=0)
  1681. C cf. commentaires 100 lignes plus haut...
  1682. C IF (NISO.NE.0.AND.ISOTYP.GT.0) THEN
  1683. LICLR=KON(2,KL,KK)
  1684. C IF (LICLR.EQ.0.AND.NISO.NE.0.AND.ISOTYP.GT.0) THEN
  1685. IF ((IMEL2.EQ.0.OR.LICLR.EQ.0)
  1686. cbp & .AND.NISO.NE.0.AND.ISOTYP.GT.0) THEN
  1687. & .AND.IISO.NE.0.AND.ISOTYP.GT.0) THEN
  1688. CPM IDNOIR au lieu de 8
  1689. NTSEG(LTSEG+3)=IDNOIR
  1690. ELSE
  1691. NTSEG(LTSEG+3)=LICLR
  1692. ENDIF
  1693. LTSEG=LTSEG+3
  1694. 5004 CONTINUE
  1695. KK=KON(1,NBCON,KK)
  1696. IF (KK.NE.0) GOTO 5005
  1697. 5003 CONTINUE
  1698. 5002 CONTINUE
  1699. SEGDES KON
  1700. C Trace des petites croix, cas de type POI1
  1701. IF (CROIX) then
  1702. C CALCUL TAILLE POUR LES CROIX
  1703. XDIB=XMAX-XMIN
  1704. YDIB=YMAX-YMIN
  1705. BLOK=MAX(XDIB,YDIB)*0.003
  1706. IPT1=MELEME
  1707. IF (IMEL2.NE.0) IPT1=MELEM2
  1708. SEGACT IPT1
  1709. SEGACT MELEME
  1710. DO 8002 ISOUS=1,MAX(1,LISOUS(/1))
  1711. IF (LISOUS(/1).NE.0) THEN
  1712. IPT1=LISOUS(ISOUS)
  1713. SEGACT IPT1
  1714. ENDIF
  1715. IF (IPT1.ITYPEL.NE.1) GOTO 8004
  1716. C----------------------------------------------------------
  1717. C TRACE DES croix
  1718. C----------------------------------------------------------
  1719. SEGACT IVU,ICPR
  1720. icc = -3
  1721. NBNN=IPT1.NUM(/1)
  1722. DO 8005 IEL=1,IPT1.NUM(/2)
  1723. IF (IVU(ICPR(IPT1.NUM(1,IEL))).GE.1) THEN
  1724. ICOOL=IPT1.ICOLOR(IEL)
  1725. C IF (ICOOL.LE.0) ICOOL=IDCOUL
  1726. CPM IDNOIR au lieu de 8
  1727. cbp IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1728. IF (IISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1729. IF (ICOOL.NE.ICC) THEN
  1730. ICC=ICOOL
  1731. CALL CHCOUL(ICC)
  1732. ENDIF
  1733. XPOS=XPROJ(1,ICPR(IPT1.NUM(1,IEL)))
  1734. YPOS=XPROJ(2,ICPR(IPT1.NUM(1,IEL)))
  1735. ZPOS=XPROJ(3,ICPR(IPT1.NUM(1,IEL)))
  1736. XTR(1)=XPOS+BLOK
  1737. YTR(1)=YPOS
  1738. ZTR(1)=ZPOS
  1739. XTR(2)=XPOS-BLOK
  1740. YTR(2)=YPOS
  1741. ZTR(2)=ZPOS
  1742. CALL POLRL(2,XTR,YTR,ZTR)
  1743. XTR(1)=XPOS
  1744. YTR(1)=YPOS+BLOK
  1745. ZTR(1)=ZPOS
  1746. XTR(2)=XPOS
  1747. YTR(2)=YPOS-BLOK
  1748. ZTR(2)=ZPOS
  1749. CALL POLRL(2,XTR,YTR,ZTR)
  1750. ENDIF
  1751. 8005 CONTINUE
  1752. 8004 CONTINUE
  1753. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1754. 8002 CONTINUE
  1755. SEGDES MELEME
  1756. endif
  1757. C Y A T IL DES BLOCAGES ???
  1758. IF (.NOT.BLOCAG) GOTO 7000
  1759. C CALCUL TAILLE POUR LES BLOCAGES
  1760. XDIB=XMAX-XMIN
  1761. YDIB=YMAX-YMIN
  1762. BLOK=MAX(XDIB,YDIB)*0.01
  1763. ICC=-3
  1764. SEGACT MELEME
  1765. IPT1=MELEME
  1766. DO 7002 ISOUS=1,MAX(1,LISOUS(/1))
  1767. IF (LISOUS(/1).NE.0) THEN
  1768. IPT1=LISOUS(ISOUS)
  1769. SEGACT IPT1
  1770. ENDIF
  1771. IF (IPT1.ITYPEL.NE.22) GOTO 7004
  1772. C----------------------------------------------------------
  1773. C TRACE DES BLOCAGES
  1774. C----------------------------------------------------------
  1775. SEGACT IVU,ICPR
  1776. NBNN=IPT1.NUM(/1)
  1777. DO 7005 IEL=1,IPT1.NUM(/2)
  1778. ICOOL=IPT1.ICOLOR(IEL)
  1779. C IF (ICOOL.LE.0) ICOOL=IDCOUL
  1780. IF (NBNN.GT.2) THEN
  1781. C IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1782. IF (ICOOL.NE.ICC) THEN
  1783. ICC=ICOOL
  1784. CALL CHCOUL(ICC)
  1785. ENDIF
  1786. JDTRAC=0
  1787. DO 7006 INO=2,NBNN
  1788. INOS=INO+1
  1789. IF (INOS.GT.NBNN) INOS = 2
  1790. IP1=ICPR(IPT1.NUM(INO,IEL))
  1791. IP2=ICPR(IPT1.NUM(INOS,IEL))
  1792. IF (IVU(IP1).GE.1.AND.IVU(IP2).GE.1) THEN
  1793. IF (JDTRAC.EQ.0) THEN
  1794. XTR(1)=XPROJ(1,IP1)
  1795. YTR(1)=XPROJ(2,IP1)
  1796. ZTR(1)=XPROJ(3,IP1)
  1797. XTR(2)=XPROJ(1,IP2)
  1798. YTR(2)=XPROJ(2,IP2)
  1799. ZTR(2)=XPROJ(3,IP2)
  1800. CALL POLRL(2,XTR,YTR,ZTR)
  1801. ENDIF
  1802. JDTRAC=1
  1803. ELSEIF (IVU(IP1).GE.1) THEN
  1804. IF (LTSEGS-LTSEG.LT.10) THEN
  1805. LTSEGS=LTSEGS+1000
  1806. SEGADJ NTSEG
  1807. ENDIF
  1808. NTSEG(LTSEG+1)=IP1
  1809. NTSEG(LTSEG+2)=IP2
  1810. NTSEG(LTSEG+3)=ICC
  1811. LTSEG=LTSEG+3
  1812. JDTRAC=0
  1813. ELSEIF (IVU(IP2).GE.1) THEN
  1814. IF (LTSEGS-LTSEG.LT.10) THEN
  1815. LTSEGS=LTSEGS+1000
  1816. SEGADJ NTSEG
  1817. ENDIF
  1818. NTSEG(LTSEG+1)=IP2
  1819. NTSEG(LTSEG+2)=IP1
  1820. NTSEG(LTSEG+3)=ICC
  1821. LTSEG=LTSEG+3
  1822. JDTRAC=0
  1823. ENDIF
  1824. 7006 CONTINUE
  1825. ELSEIF (NBNN.EQ.2.AND.IVU(ICPR(IPT1.NUM(2,IEL))).GE.1) THEN
  1826. cbp IF (NISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1827. IF (IISO.NE.0.AND.ISOTYP.GT.0) ICOOL=IDNOIR
  1828. IF (ICOOL.NE.ICC) THEN
  1829. ICC=ICOOL
  1830. CALL CHCOUL(ICC)
  1831. ENDIF
  1832. XPOS=XPROJ(1,ICPR(IPT1.NUM(2,IEL)))
  1833. YPOS=XPROJ(2,ICPR(IPT1.NUM(2,IEL)))
  1834. ZPOS=XPROJ(3,ICPR(IPT1.NUM(2,IEL)))
  1835. XTR(1)=XPOS+BLOK
  1836. YTR(1)=YPOS
  1837. ZTR(1)=ZPOS
  1838. XTR(2)=XPOS
  1839. YTR(2)=YPOS+BLOK
  1840. ZTR(2)=ZPOS
  1841. XTR(3)=XPOS-BLOK
  1842. YTR(3)=YPOS
  1843. ZTR(3)=ZPOS
  1844. XTR(4)=XPOS
  1845. YTR(4)=YPOS-BLOK
  1846. ZTR(4)=ZPOS
  1847. XTR(5)=XTR(1)
  1848. YTR(5)=YTR(1)
  1849. ZTR(5)=ZTR(1)
  1850. CALL POLRL(5,XTR,YTR,ZTR)
  1851. ENDIF
  1852. 7005 CONTINUE
  1853. 7004 CONTINUE
  1854. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1855. 7002 CONTINUE
  1856. SEGDES MELEME
  1857. 7000 CONTINUE
  1858. if (iogra.eq.6) goto 4202
  1859. IF (ICACHE.NE.0) THEN
  1860. C PP FACE avec trait blanc
  1861. CALL DICHO3(XPROJ,MELEME,ICPR,XMIN,XMAX,
  1862. * YMIN,YMAX,IVU,NTSEG,NELEM,IICOL,IDEFCO,lblanc,LTSEG)
  1863. C PP * YMIN,YMAX,IVU,NTSEG,NELEM,IICOL,IDEFCO)
  1864. ENDIF
  1865. GOTO 4202
  1866. 4201 CONTINUE
  1867. C----------------------------------------------------------
  1868. C
  1869. C TRACE ECLATE DES ELEMENTS
  1870. C
  1871. C----------------------------------------------------------
  1872. SEGACT ICPR
  1873. C IF (IFADES.EQ.1) GOTO 4400 PV JUIN 86
  1874. SEGACT MELEME
  1875. ICOLE=0
  1876. IPT1=MELEME
  1877. DO 4111 IO=1,MAX(1,LISOUS(/1))
  1878. IF (LISOUS(/1).NE.0) THEN
  1879. IPT1=LISOUS(IO)
  1880. SEGACT IPT1
  1881. ENDIF
  1882. K=IPT1.ITYPEL
  1883. IDEP=LPT(K)
  1884. IFIN=IDEP+2*LPL(K)-2
  1885. IFIN2=IFIN
  1886. IF (LPL(K).EQ.0) THEN
  1887. IF (LPT(K).EQ.0)THEN
  1888. GOTO 4112
  1889. ELSE
  1890. C Polygone
  1891. IFIN=IDEP+2*IPT1.NUM(/1)-2
  1892. IFIN2=IFIN -2
  1893. ENDIF
  1894. ENDIF
  1895. 4112 CONTINUE
  1896. C IFIN=IDEP+2*LPL(K)-2
  1897. DO 4115 I=1,IPT1.NUM(/2)
  1898. IF (IDEFCO.EQ.1.AND.IPT1.ICOLOR(I).NE.IICOL) GOTO 4115
  1899. XG=0.
  1900. YG=0.
  1901. ZG=0.
  1902. ZN=0.
  1903. N=IPT1.NUM(/1)
  1904. DO 4116 J=1,N
  1905. XG=XG+XPROJ(1,ICPR(IPT1.NUM(J,I)))
  1906. YG=YG+XPROJ(2,ICPR(IPT1.NUM(J,I)))
  1907. ZG=ZG+XPROJ(3,ICPR(IPT1.NUM(J,I)))
  1908. 4116 CONTINUE
  1909. XG=XG/N
  1910. YG=YG/N
  1911. ZG=ZG/N
  1912. I3=0
  1913. IF (ICOLE.NE.IPT1.ICOLOR(I)) THEN
  1914. ICOLE=IPT1.ICOLOR(I)
  1915. CALL CHCOUL(ICOLE)
  1916. ENDIF
  1917. ITR=1
  1918. ILTEL=LTEL(1,K)
  1919. IF (ILTEL.NE.0) THEN
  1920. DO 4117 IF=1,ILTEL
  1921. ITR=0
  1922. ILTAD=LTEL(2,K)
  1923. ITYP=LDEL(1,ILTAD+IF-1)
  1924. IAD=LDEL(2,ILTAD+IF-1)
  1925. DO 4118 J=1,KDFAC(1,ITYP)
  1926. I1=ICPR(IPT1.NUM(LFAC(IAD+J-1),I))
  1927. XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  1928. YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  1929. ZR=ZG+(XPROJ(3,I1)-ZG)*XECLAT
  1930. ITR=ITR+1
  1931. XTR(ITR)=XR
  1932. YTR(ITR)=YR
  1933. ZTR(ITR)=ZR
  1934. 4118 CONTINUE
  1935. ITR=ITR+1
  1936. XTR(ITR)=XTR(1)
  1937. YTR(ITR)=YTR(1)
  1938. ZTR(ITR)=ZTR(1)
  1939. IF (IFADES.EQ.0) THEN
  1940. CALL POLRL(ITR,XTR,YTR,ZTR)
  1941. ELSE
  1942. CALL TRFACE(ITR,XTR,YTR,ZTR,ZN,ICOLE,IEFF)
  1943. CALL CHCOUL(IDNOIR)
  1944. CALL POLRL(ITR,XTR,YTR,ZTR)
  1945. CALL CHCOUL(ICOLE)
  1946. ENDIF
  1947. ITR=0
  1948. 4117 CONTINUE
  1949. ELSE
  1950. DO 4114 J=IDEP,IFIN,2
  1951. IF (J.LE.IFIN2) THEN
  1952. I1=ICPR(IPT1.NUM(KSEGM(J),I))
  1953. I2=ICPR(IPT1.NUM(KSEGM(J+1),I))
  1954. ELSE
  1955. I1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),I))
  1956. I2=ICPR(IPT1.NUM(KSEGM(1),I))
  1957. ENDIF
  1958. XR=XG+(XPROJ(1,I1)-XG)*XECLAT
  1959. YR=YG+(XPROJ(2,I1)-YG)*XECLAT
  1960. ZR=ZG+(XPROJ(3,I1)-ZG)*XECLAT
  1961. IF (I1.NE.I3) THEN
  1962. if (ifades.eq.0) then
  1963. IF (ITR.NE.1) call POLRL(ITR,XTR,YTR,ZTR)
  1964. else
  1965. IF (ITR.NE.1) CALL trface(ITR,XTR,YTR,ZTR,zn,icole,ieff)
  1966. endif
  1967. ITR=1
  1968. XTR(1)=XR
  1969. YTR(1)=YR
  1970. ZTR(1)=ZR
  1971. ENDIF
  1972. XR=XG+(XPROJ(1,I2)-XG)*XECLAT
  1973. YR=YG+(XPROJ(2,I2)-YG)*XECLAT
  1974. ZR=ZG+(XPROJ(3,I2)-ZG)*XECLAT
  1975. ITR=ITR+1
  1976. XTR(ITR)=XR
  1977. YTR(ITR)=YR
  1978. ZTR(ITR)=ZR
  1979. I3=I2
  1980. 4114 CONTINUE
  1981. if (ifades.eq.0) then
  1982. IF (ITR.NE.1) CALL POLRL(ITR,XTR,YTR,ZTR)
  1983. else
  1984. IF (ITR.NE.1) CALL trface(ITR,XTR,YTR,ZTR,zn,icole,ieff)
  1985. endif
  1986. ITR=1
  1987. ENDIF
  1988. 4115 CONTINUE
  1989. IF (LISOUS(/1).NE.0) SEGDES IPT1
  1990. 4111 CONTINUE
  1991. SEGDES MELEME
  1992. 4202 CONTINUE
  1993.  
  1994. C----------------------------------------------------------
  1995. C TRAITEMENT DES PARAMETRES TELS QUE NOEUD,QUALI,...
  1996. C (AVANT AFFICHAGE)
  1997. C----------------------------------------------------------
  1998. IF (IQUALI.EQ.0) GOTO 500
  1999. SEGACT XPROJ,IVU,ICPR
  2000. PAS=(X2-X1)/(XMA-XMI)
  2001. CALL INSEGT(3,IRESS)
  2002. C ON MET LES NOMS LA OU ON PEUT
  2003. if(nbesc.ne.0) segact ipiloc
  2004. DO 501 IOB=1,LMNNOM
  2005. C IGNORER LES OBJETS TEMPORAIRES OU INVALIDES
  2006. ICOLE=0
  2007. IF (INOOB2(IOB).NE.'MAILLAGE') GOTO 511
  2008. IPVH=INOOB1(IOB)
  2009. IDEBCH=IPCHAR(IPVH)
  2010. IFINCH=IPCHAR(IPVH+1)-1
  2011. TXT= ICHARA(IDEBCH:IFINCH)
  2012. IF (TXT(1:1).EQ.'#') GOTO 501
  2013. IF (TXT(1:1).EQ.' ') GOTO 501
  2014. IPT4=IOUEP2(IOB)
  2015. IF (IPT4.EQ.0) GOTO 501
  2016. SEGACT IPT4
  2017. XP=0
  2018. YP=0
  2019. ZP=0
  2020. NP=0
  2021. IPT5=IPT4
  2022. DO 503 ISB=1,MAX(1,IPT4.LISOUS(/1))
  2023. IF (IPT4.LISOUS(/1).NE.0) THEN
  2024. IPT5=IPT4.LISOUS(ISB)
  2025. SEGACT IPT5
  2026. ENDIF
  2027. CPM NBCOUL-1 au lieu de 7
  2028. DO 507 I=1,NBCOUL-1
  2029. ITEST(I)=0
  2030. 507 CONTINUE
  2031. DO 504 J=1,IPT5.NUM(/2)
  2032. IF (IPT5.ICOLOR(J).NE.0) THEN
  2033. ITEST(IPT5.ICOLOR(J))=1
  2034. ELSE
  2035. C ITEST(7)=1
  2036. ENDIF
  2037. DO 5041 I=1,IPT5.NUM(/1)
  2038. K=ICPR(IPT5.NUM(I,J))
  2039. IF (K.EQ.0) GOTO 505
  2040. IF (IVU(K).LE.0) GOTO 5041
  2041. NP=NP+1
  2042. XP=XP+XPROJ(1,K)
  2043. YP=YP+XPROJ(2,K)
  2044. ZP=ZP+XPROJ(3,K)
  2045. 5041 CONTINUE
  2046. 504 CONTINUE
  2047. IF (IPT4.LISOUS(/1).NE.0) SEGDES IPT5
  2048. 503 CONTINUE
  2049. SEGDES IPT4
  2050. IF (NP.EQ.0) GOTO 501
  2051. XP=XP/NP
  2052. YP=YP/NP
  2053. ZP=ZP/NP
  2054. C IF (XP.LT.XMI.OR.XP.GT.XMA.OR.YP.LT.YMI.OR.YP.GT.YMA) GOTO 501
  2055. ICOLE=0
  2056. CPM NBCOUL-1 au lieu de 7
  2057. C couleur avec melange eventuel si plusieurs
  2058. DO 508 I=1,NBCOUL-1
  2059. IF (ITEST(I).EQ.1) THEN
  2060. IF (ICOLE.EQ.0) THEN
  2061. ICOLE=I
  2062. ELSE
  2063. ICOLE=ITABM(ICOLE,I)
  2064. ENDIF
  2065. ENDIF
  2066. 508 CONTINUE
  2067. IF (IDEFCO.EQ.1.AND.ICOLE.NE.IICOL) GOTO 501
  2068. CALL CHCOUL(ICOLE)
  2069. XP=PAS*(XP-XMI)+X1
  2070. YP=PAS*(YP-YMI)+Y1
  2071. ZP=PAS*(ZP-ZMI)+ZMI
  2072. C TXT= INOOB1(IOB)
  2073. CALL TRLABL(XP,YP,ZP,TXT,8,0.15)
  2074. GOTO 501
  2075. 505 CONTINUE
  2076. SEGDES IPT4,IPT5
  2077. 511 CONTINUE
  2078. C AU TOUR DES POINTS NOMMES
  2079. IF (INOOB2(IOB).NE.'POINT ') GOTO 501
  2080. IF (IOUEP2(IOB).EQ.0) GOTO 501
  2081. K=ICPR(IOUEP2(IOB))
  2082. IF (K.EQ.0) GOTO 501
  2083. IF (IVU(K).LE.0) GOTO 501
  2084. C IF (XPROJ(1,K).LT.XMI.OR.XPROJ(1,K).GT.XMA) GOTO 501
  2085. C IF (XPROJ(2,K).LT.YMI.OR.XPROJ(2,K).GT.YMA) GOTO 501
  2086. ITRUC=0
  2087. IF (IDEFCO.EQ.1) THEN
  2088. 512 DO 509 I=1,NBCONR
  2089. CPM ?????????? pb si codage KON en binaire ???????????
  2090. IF (KON(2,I,K).EQ.IICOL) THEN
  2091. ITRUC=1
  2092. GOTO 510
  2093. ENDIF
  2094. 509 CONTINUE
  2095. IF (KON(1,NBCON,K).NE.0) THEN
  2096. K=KON(1,NBCON,K)
  2097. GOTO 512
  2098. ENDIF
  2099. ELSE
  2100. ITRUC=1
  2101. ENDIF
  2102. 510 IF (ITRUC.EQ.1) THEN
  2103. CALL CHCOUL(0)
  2104. XP=XPROJ(1,K)
  2105. YP=XPROJ(2,K)
  2106. ZP=XPROJ(3,K)
  2107. XP=PAS*(XP-XMI)+X1
  2108. YP=PAS*(YP-YMI)+Y1
  2109. ZP=PAS*(ZP-ZMI)+ZMI
  2110. IPVH=INOOB1(IOB)
  2111. IDEBCH=IPCHAR(IPVH)
  2112. IFINCH=IPCHAR(IPVH+1)-1
  2113. TXT= ICHARA(IDEBCH:IFINCH)
  2114. CALL TRLABL(XP,YP,ZP,TXT,8,0.15)
  2115. ENDIF
  2116. 501 CONTINUE
  2117. if(nbesc.ne.0) segdes ipiloc
  2118. IF (IRESU.EQ.3) GOTO 6101
  2119. 500 IF (INUMNO.EQ.0) GOTO 531
  2120. SEGACT XPROJ,IVU,ICPR
  2121. PAS=(X2-X1)/(XMA-XMI)
  2122. CALL INSEGT(4,IRESS)
  2123. C INDICATION DES NUMEROS DE NOEUDS
  2124. CALL CHCOUL(0)
  2125. DO 530 I=1,NBPTS
  2126. K=ICPR(I)
  2127. IF (K.EQ.0) GOTO 530
  2128. IF (IVU(K).LE.0) GOTO 530
  2129. C IF (XPROJ(1,K).LT.XMI.OR.XPROJ(1,K).GT.XMA) GOTO 530
  2130. C IF (XPROJ(2,K).LT.YMI.OR.XPROJ(2,K).GT.YMA) GOTO 530
  2131. ITRUC=0
  2132. IF (IDEFCO.EQ.1) THEN
  2133. 521 DO 519 J=1,NBCONR
  2134. CPM ?????????? pb si codage KON en binaire ???????????
  2135. IF (KON(2,J,K).EQ.IICOL) THEN
  2136. ITRUC=1
  2137. GOTO 520
  2138. ENDIF
  2139. 519 CONTINUE
  2140. IF (KON(1,NBCON,K).NE.0) THEN
  2141. K=KON(1,NBCON,K)
  2142. GOTO 521
  2143. ENDIF
  2144. ELSE
  2145. ITRUC=1
  2146. ENDIF
  2147. 520 IF (ITRUC.EQ.1) THEN
  2148. IF (I.LT.10) THEN
  2149. FMTX='(I1,7X)'
  2150. ELSEIF (I.LT.100) THEN
  2151. FMTX='(I2,6X)'
  2152. ELSEIF (I.LT.1000) THEN
  2153. FMTX='(I3,5X)'
  2154. ELSEIF (I.LT.10000) THEN
  2155. FMTX='(I4,4X)'
  2156. ELSEIF (I.LT.100000) THEN
  2157. FMTX='(I5,3X)'
  2158. ELSEIF (I.LT.1000000) THEN
  2159. FMTX='(I6,2X)'
  2160. ENDIF
  2161. WRITE (TXT,FMT=FMTX) I
  2162. XP=XPROJ(1,K)
  2163. YP=XPROJ(2,K)
  2164. ZP=XPROJ(3,K)
  2165. XP=PAS*(XP-XMI)+X1
  2166. YP=PAS*(YP-YMI)+Y1
  2167. ZP=PAS*(ZP-ZMI)+ZMI
  2168. CALL TRLABL(XP,YP,ZP,TXT,8,0.15)
  2169. ENDIF
  2170. 530 CONTINUE
  2171. IF (IRESU.EQ.4) GOTO 6101
  2172. 531 CONTINUE
  2173. C+++*
  2174. IF (LABCO2.EQ.0) GOTO 538
  2175. MVECTS=MVECTE
  2176. MVECTE=LABCO2(3,IDEF)
  2177. IF (MVECTE.EQ.0) GOTO 538
  2178. SEGACT XPROJ,IVU,ICPR
  2179.  
  2180. C TRACE DES VECTEURS SI IL Y A LIEU
  2181. SEGACT MVECTE
  2182. NVEC=NOCOUL(/1)
  2183. KABCO2=LABCO2(1,IDEF)
  2184. KXPRO2=LABCO2(2,IDEF)
  2185. DO 541 IVEC=1,NVEC
  2186. C Mots reserves : contraintes principales / fissures
  2187. CALL PLACE(MOVE,6,IPLA,NOCOVE(IVEC,1))
  2188. IF (IPLA.EQ.0) THEN
  2189. C Cas classique des vecteurs
  2190. CPM NLEGMX au lieu de 8
  2191. IF (NVECL.LT.NLEGMX) THEN
  2192. IFLE = 0
  2193. NVECL=NVECL+1
  2194. VAMPF(NVECL)=REAL(AMPF(IVEC))
  2195. IF (VAMPF(NVECL).LT.0) IFLE = -1
  2196. NVCOL(NVECL)=NOCOUL(IVEC)
  2197. NVLEG(1,NVECL)=NOCOVE(IVEC,1)
  2198. cbp petit ajout pour eviter pb si vecteurs crees depuis mchaml
  2199. NVLEG(2,NVECL)=' '
  2200. NVLEG(3,NVECL)=' '
  2201. IDVECT=NOCOVE(/3)
  2202. IF(IDVECT.GT.1) THEN
  2203. NVLEG(2,NVECL)=NOCOVE(IVEC,2)
  2204. IF (IDIM.EQ.3) NVLEG(3,NVECL)=NOCOVE(IVEC,3)
  2205. ENDIF
  2206. cbp fin petit ajout
  2207. ENDIF
  2208. ELSE
  2209. C Cas des contraintes principales
  2210. IF (IPLA.LE.3) IFLE = 1
  2211. C Cas des fissures
  2212. IF (IPLA.GT.3) IFLE = 2
  2213. IF (IFLE.EQ.1.AND.NOCOVE(2,1).EQ.NOCOVE(1,1)) THEN
  2214. NVECL = 1
  2215. VAMPF(1)=REAL(AMPF(1))
  2216. NVCOL(1)=NOCOUL(1)
  2217. NVLEG(1,1)=NOCOVE(1,1)
  2218. ELSE
  2219. NVECL = 2
  2220. VAMPF(1)=REAL(AMPF(1))
  2221. NVCOL(1)=NOCOUL(1)
  2222. NVLEG(1,1)=NOCOVE(1,1)
  2223. VAMPF(2)=REAL(AMPF(2))
  2224. NVCOL(2)=NOCOUL(2)
  2225. NVLEG(1,2)=NOCOVE(2,1)
  2226. IF (IDIM.EQ.3) THEN
  2227. NVECL = 3
  2228. VAMPF(3)=REAL(AMPF(3))
  2229. NVCOL(3)=NOCOUL(3)
  2230. NVLEG(1,3)=NOCOVE(3,1)
  2231. ENDIF
  2232. ENDIF
  2233. ENDIF
  2234. XPRO2=KXPRO2(IVEC)
  2235. ICOR2=KABCO2(2,IVEC)
  2236. SEGACT XPRO2,ICOR2,XPROJ,IVU,ICPR
  2237. INVCOU=NOCOUL(IVEC)
  2238. CALL CHCOUL(INVCOU)
  2239. DO 540 I=1,NBPTS
  2240. K=ICPR(I)
  2241. IF (K.EQ.0) GOTO 540
  2242. IF (ICOR2(K).EQ.0) GOTO 540
  2243. IF (IVU(K).LE.0) GOTO 540
  2244. IF (IFLE.EQ.-1) THEN
  2245. C Fleches pointant vers les points
  2246. UX=XPROJ(1,K)-XPRO2(1,K)
  2247. UY=XPROJ(2,K)-XPRO2(2,K)
  2248. UZ=XPROJ(3,K)-XPRO2(3,K)
  2249. XTR(1)=XPRO2(1,K)
  2250. YTR(1)=XPRO2(2,K)
  2251. ZTR(1)=XPRO2(3,K)
  2252. XTR(2)=XPROJ(1,K)-UX/10.
  2253. YTR(2)=XPROJ(2,K)-UY/10.
  2254. ZTR(2)=XPROJ(3,K)-UZ/10.
  2255. U1=XPROJ(1,K)-UX/3-UY/5
  2256. V1=XPROJ(2,K)-UY/3+UX/5
  2257. W1=XPROJ(3,K)
  2258. XTR(3)=U1
  2259. YTR(3)=V1
  2260. ZTR(3)=W1
  2261. XTR(4)=XPROJ(1,K)
  2262. YTR(4)=XPROJ(2,K)
  2263. ZTR(4)=XPROJ(3,K)
  2264. U1=XPROJ(1,K)-UX/3+UY/5
  2265. V1=XPROJ(2,K)-UY/3-UX/5
  2266. W1=XPROJ(3,K)
  2267. XTR(5)=U1
  2268. YTR(5)=V1
  2269. ZTR(5)=W1
  2270. XTR(6)=XPROJ(1,K)-UX/10.
  2271. YTR(6)=XPROJ(2,K)-UY/10.
  2272. ZTR(6)=XPROJ(3,K)
  2273. CALL POLRL(6,XTR,YTR,ZTR)
  2274. ELSE IF (IFLE.EQ.0) THEN
  2275. C Fleches partant des points
  2276.  
  2277. XTR(1)=XPROJ(1,K)
  2278. YTR(1)=XPROJ(2,K)
  2279. ZTR(1)=XPROJ(3,K)
  2280. UX=XPRO2(1,K)-XPROJ(1,K)
  2281. UY=XPRO2(2,K)-XPROJ(2,K)
  2282. UZ=XPRO2(3,K)-XPROJ(3,K)
  2283. XTR(2)=XPRO2(1,K)-UX/10.
  2284. YTR(2)=XPRO2(2,K)-UY/10.
  2285. ZTR(2)=XPRO2(3,K)
  2286. U1=XPRO2(1,K)-UX/3-UY/5
  2287. V1=XPRO2(2,K)-UY/3+UX/5
  2288. W1=XPRO2(3,K)
  2289. XTR(3)=U1
  2290. YTR(3)=V1
  2291. ZTR(3)=W1
  2292. XTR(4)=XPRO2(1,K)
  2293. YTR(4)=XPRO2(2,K)
  2294. ZTR(4)=XPRO2(3,K)
  2295. U1=XPRO2(1,K)-UX/3+UY/5
  2296. V1=XPRO2(2,K)-UY/3-UX/5
  2297. W1=XPRO2(3,K)
  2298. XTR(5)=U1
  2299. YTR(5)=V1
  2300. ZTR(5)=W1
  2301. XTR(6)=XPRO2(1,K)-UX/10.
  2302. YTR(6)=XPRO2(2,K)-UY/10.
  2303. ZTR(6)=XPRO2(3,K)
  2304. CALL POLRL(6,XTR,YTR,ZTR)
  2305. ELSE IF (IFLE.EQ.1) THEN
  2306. C contraintes principales
  2307. IF (ICOR2(K).EQ.1) THEN
  2308. NTR = 6
  2309. XTR(1) = XPROJ(1,K)
  2310. YTR(1) = XPROJ(2,K)
  2311. ZTR(1) = XPROJ(3,K)
  2312. UX = XPRO2(1,K) - XPROJ(1,K)
  2313. UY = XPRO2(2,K) - XPROJ(2,K)
  2314. UZ = XPRO2(3,K) - XPROJ(3,K)
  2315. XTR(2) = XPRO2(1,K) - UX/10
  2316. YTR(2) = XPRO2(2,K) - UY/10
  2317. ZTR(2) = XPRO2(3,K)
  2318. XTR(3) = XPRO2(1,K) - UX/3 - UY/5
  2319. YTR(3) = XPRO2(2,K) - UY/3 + UX/5
  2320. ZTR(3) = XPRO2(3,K)
  2321. XTR(4) = XPRO2(1,K)
  2322. YTR(4) = XPRO2(2,K)
  2323. ZTR(4) = XPRO2(3,K)
  2324. XTR(5) = XPRO2(1,K) - UX/3 + UY/5
  2325. YTR(5) = XPRO2(2,K) - UY/3 - UX/5
  2326. ZTR(5) = XPRO2(3,K)
  2327. XTR(6) = XPRO2(1,K) - UX/10.
  2328. YTR(6) = XPRO2(2,K) - UY/10.
  2329. ZTR(6) = XPRO2(3,K)
  2330. CALL POLRL(NTR,XTR,YTR,ZTR)
  2331. ELSE
  2332. NTR = 6
  2333. XTR(1) = XPROJ(1,K)
  2334. YTR(1) = XPROJ(2,K)
  2335. ZTR(1) = XPROJ(3,K)
  2336. XTR(2) = XPRO2(1,K)
  2337. YTR(2) = XPRO2(2,K)
  2338. ZTR(2) = XPRO2(3,K)
  2339. UX = XPRO2(1,K) - XPROJ(1,K)
  2340. UY = XPRO2(2,K) - XPROJ(2,K)
  2341. UZ = XPRO2(3,K) - XPROJ(3,K)
  2342. XTR(3) = XPRO2(1,K) + UX/3 + UY/5
  2343. YTR(3) = XPRO2(2,K) + UY/3 - UX/5
  2344. ZTR(3) = XPRO2(3,K)
  2345. XTR(4) = XPRO2(1,K) + UX/10
  2346. YTR(4) = XPRO2(2,K) + UY/10
  2347. ZTR(4) = XPRO2(3,K)
  2348. XTR(5) = XPRO2(1,K) + UX/3 - UY/5
  2349. YTR(5) = XPRO2(2,K) + UY/3 + UX/5
  2350. ZTR(5) = XPRO2(3,K)
  2351. XTR(6) = XPRO2(1,K)
  2352. YTR(6) = XPRO2(2,K)
  2353. ZTR(6) = XPRO2(3,K)
  2354. CALL POLRL(NTR,XTR,YTR,ZTR)
  2355. ENDIF
  2356. ELSE IF (IFLE.EQ.2) THEN
  2357. C fissures
  2358. IF (ICOR2(K).EQ.-1) GOTO 540
  2359. NTR = 2
  2360. XTR(1) = XPROJ(1,K)
  2361. YTR(1) = XPROJ(2,K)
  2362. ZTR(1) = XPROJ(3,K)
  2363. XTR(2) = XPRO2(1,K)
  2364. YTR(2) = XPRO2(2,K)
  2365. ZTR(2) = XPRO2(3,K)
  2366. CALL POLRL(NTR,XTR,YTR,ZTR)
  2367. ENDIF
  2368. 540 CONTINUE
  2369. SEGSUP XPRO2,ICOR2
  2370. 541 CONTINUE
  2371. SEGSUP KXPRO2,KABCO2
  2372. MVECTE = MVECTS
  2373. 538 CONTINUE
  2374. IF (INUMEL.EQ.0) GOTO 532
  2375. SEGACT XPROJ,IVU,ICPR
  2376. PAS=(X2-X1)/(XMA-XMI)
  2377. CALL INSEGT(5,IRESS)
  2378. SEGACT MELEME
  2379. IPT1=MELEME
  2380. IF (MCOUP.NE.0) GOTO 537
  2381. DO 534 II=1,MAX(1,LISOUS(/1))
  2382. IF (LISOUS(/1).NE.0) IPT1=LISOUS(II)
  2383. SEGACT IPT1
  2384. NBNN=IPT1.NUM(/1)
  2385. NBELEM=IPT1.NUM(/2)
  2386. DO 535 L=1,NBELEM
  2387. XG=0.
  2388. YG=0.
  2389. ZG=0.
  2390. NG=0
  2391. DO 536 N=1,NBNN
  2392. I=ICPR(IPT1.NUM(N,L))
  2393. IF (IVU(I).LE.0) GOTO 536
  2394. XG=XG+XPROJ(1,I)
  2395. YG=YG+XPROJ(2,I)
  2396. ZG=ZG+XPROJ(3,I)
  2397. NG=NG+1
  2398. 536 CONTINUE
  2399. IF (NG.EQ.0) GOTO 535
  2400. XG=XG/NG
  2401. YG=YG/NG
  2402. ZG=ZG/NG
  2403. C IF (XG.LT.XMI.OR.XG.GT.XMA.OR.YG.LT.YMI.OR.YG.GT.YMA) GOTO 535
  2404. INVCOU=IPT1.ICOLOR(L)
  2405. C IF (INVCOU.EQ.0) INVCOU=IDCOUL
  2406. IF (IDEFCO.EQ.1.AND.INVCOU.NE.IICOL) GOTO 535
  2407. CALL CHCOUL(INVCOU)
  2408. IF (L.LT.10) THEN
  2409. FMTX='(I1,7X)'
  2410. ELSEIF (L.LT.100) THEN
  2411. FMTX='(I2,6X)'
  2412. ELSEIF (L.LT.1000) THEN
  2413. FMTX='(I3,5X)'
  2414. ELSEIF (L.LT.10000) THEN
  2415. FMTX='(I4,4X)'
  2416. ELSEIF (L.LT.100000) THEN
  2417. FMTX='(I5,3X)'
  2418. ELSEIF (L.LT.1000000) THEN
  2419. FMTX='(I6,2X)'
  2420. ENDIF
  2421. WRITE (TXT,FMT=FMTX) L
  2422. XG=PAS*(XG-XMI)+X1
  2423. YG=PAS*(YG-YMI)+Y1
  2424. ZG=PAS*(ZG-ZMI)+ZMI
  2425. CALL TRLABL(XG,YG,ZG,TXT,8,0.15)
  2426. 535 CONTINUE
  2427. IF (LISOUS(/1).NE.0) SEGDES IPT1
  2428. 534 CONTINUE
  2429. 537 SEGDES MELEME
  2430. IF (IRESU.EQ.5.OR.IRESU.EQ.7) GOTO 6101
  2431. 532 CONTINUE
  2432. IF (IDEFOR.EQ.0) GOTO 6101
  2433. SEGSUP KON,XPROJ,ICPR,IVU
  2434. IF (XPRO2.NE.0) SEGSUP XPRO2
  2435. IF (MCOUP.NE.0) THEN
  2436. C NETTOYAGE APRES COUPE
  2437. C SEGSUP MCOUP
  2438. SEGACT MCOORD*MOD
  2439. C SEGADJ MCOORD
  2440. C SEGACT MELEME
  2441. C DO 8801 IO=1,LISOUS(/1)
  2442. C* IPT1=LISOUS(IO)
  2443. C SEGSUP IPT1
  2444. C 8801 CONTINUE
  2445. C SEGSUP MELEME
  2446. ENDIF
  2447. GOTO 6099
  2448. C<<<< FIN DE BOUCLE SUR LES DEFORMEES OU VECTEURS <<<<<<<<<<<<<<<<<<<<<<
  2449.  
  2450.  
  2451. C---- POINT D'ARRIVEE EN FIN DE BOUCLE SUR LES DEFORMEES OU VECTEURS ---
  2452. 6100 CONTINUE
  2453. IDEFS=IDEFOR
  2454. IDEFOR=0
  2455. IF (IANIM.NE.0) CALL TRIMAG(NDEF+1)
  2456. IF (KABEL.NE.0) SEGSUP KABEL
  2457. IF (KABEL2.NE.0) SEGSUP KABEL2
  2458. IF (KABCPR.NE.0) SEGSUP KABCPR
  2459. IF (KABCP2.NE.0) SEGSUP KABCP2
  2460. SEGSUP KABCOR
  2461. IF (KABCO3.NE.0) SEGSUP KABCO3
  2462. IF (LABCO2.NE.0) SEGSUP LABCO2
  2463. IF (LABCO3.NE.0) SEGSUP LABCO3
  2464. 6101 CONTINUE
  2465. CALL MAJSEG(1,IRESU,IQUALI,INUMNO,INUMEL)
  2466. IF (ZCHAM) THEN
  2467. C ZCHAM=.TRUE.
  2468. SEGACT MCHPOI,icpr,vcpcha
  2469. do ibc=1,ipchp(/1)
  2470. msoupo=ipchp(ibc)
  2471. segact msoupo
  2472. do ibcn=1,nocomp(/2)
  2473. if(compch(lcomp).eq.nocomp(ibcn)) go to 6108
  2474. enddo
  2475. go to 6107
  2476. 6108 continue
  2477. IPT6=IGEOC
  2478. SEGACT IPT6
  2479. MPOVAL=IPOVAL
  2480. SEGACT MPOVAL
  2481. do I=1, IPT6.NUM(/2)
  2482. IJ=IPT6.NUM(1,I)
  2483. ijj=icpr(ij)
  2484. WRITE(VALCH,FMT='(E10.3)') vcpcha(ij)
  2485. CALL TRLABL(XPROJ(1,IJj),XPROJ(2,IJj),0.,
  2486. $ VALCH,LEN(VALCH),0.15)
  2487. enddo
  2488. segdes ipt6,mpoval
  2489. 6107 continue
  2490. segdes msoupo
  2491. enddo
  2492. segdes mchpoi,icpr,vcpcha
  2493. ENDIF
  2494.  
  2495. * option NOLEN : pas d'informations
  2496. IF(ZNOLE) GOTO 6105
  2497. C BERTIN : fin affichage CHAMPOIN
  2498. IF (INWDS.AND.VALEUR) THEN
  2499. C AFFICHAGE DES LABELS DES ISOVALEURS
  2500. CALL FVALIS(1,IRESU,NHAUT,NISO)
  2501. iresu=3
  2502. CALL INSEGT(7,iresu)
  2503. CALL CHCOUL(0)
  2504. NHAUT=NHAUT+INT(YHAUT)
  2505.  
  2506. NDEC=0
  2507. IF (NISO.NE.0) THEN
  2508. C Legende des isovaleurs
  2509. IF(TXISO.NE.' ') VALISO=TXISO
  2510. IF (NCOMP.NE.0) VALISO=COMPCH(LCOMP)(1:12)
  2511. LVS=LONG(VALISO)
  2512. CALL TRLABL(XHAUT+0.1,FLOAT(NHAUT+2),0.,VALISO(1:LVS),LVS,0.17)
  2513. C min et max
  2514. WRITE (ZONE,FMT='(1PE9.2)') VCHMIN
  2515. CALL TRLABL(XHAUT+0.,FLOAT(NHAUT),0.,'>'//ZONE,10,0.17)
  2516.  
  2517. IF (ZDATE) CALL TRLABL(-1.4,FLOAT(NHAUT-50),0.,BUFFER,26,
  2518. $ 0.17)
  2519. WRITE (ZONE,FMT='(1PE9.2)') VCHMAX
  2520. CALL TRLABL(XHAUT+0.,FLOAT(NHAUT+1),0.,'<'//ZONE,10,0.17)
  2521. C NISO=MIN(15,NISO)
  2522. C NDEC : amplitude verticale de la gamme d'isovaleurs
  2523. NDEC = 25
  2524. PDEC = REAL(NDEC)
  2525. PDDEC= PDEC/NISO
  2526. cBP pour espacer les legendes avec VING DIX ou CINQ labels maxi
  2527. XDEC=0.98
  2528. if(NDEC2.eq.1) XDEC=XDEC*25./21.
  2529. if(NDEC2.eq.2) XDEC=XDEC*25./11.
  2530. if(NDEC2.eq.3) XDEC=XDEC*25./6.
  2531. FAIT = -1
  2532. CPM NHAUT= NHAUT
  2533. NBAS = NHAUT - 1 - NDEC
  2534. DO 6102 I=1,NISO
  2535. PYB = NBAS + ((I-1)*PDDEC)
  2536. IF (ISOTYP.NE.0) THEN
  2537. C petit carre colore
  2538. PX(1)=XHAUT+0.
  2539. PX(2)=XHAUT+0.09
  2540. PX(3)=XHAUT+0.09
  2541. PX(4)=XHAUT+0.
  2542. PY(1)=PYB
  2543. PY(2)=PYB
  2544. PY(3)=PYB + PDDEC
  2545. PY(4)=PYB + PDDEC
  2546. C si moins de 16 isov., on prend une couleur
  2547. C correspondante sur deux (NISO<8) ou sur une (NISO>=8)
  2548. IF (NISO.LT.16) THEN
  2549. c CALL TRAISO(4,PX,PY,ICOTAB(I*(2-NISO/8)))
  2550. CALL TRAISO(4,PX,PY,ICOTAB(ISOTAB(I,NISO)))
  2551. ELSE
  2552. CALL TRAISO(4,PX,PY,I)
  2553. ENDIF
  2554. IF (I*PDDEC-FAIT.LT. XDEC ) GOTO 6102
  2555. C valeur seuil pour l'affichage de la legende isovaleur
  2556. IF (I.GT.1) THEN
  2557. WRITE (ZONE,FMT='(1PG9.2)') VCHC(I-1)
  2558. CALL CHCOUL(0)
  2559. CALL TRLABL(XHAUT+0.1,PYB,0.,ZONE,10,0.17)
  2560. ENDIF
  2561. FAIT=I*PDDEC
  2562. ELSE
  2563. C lettre coloree
  2564. IF (NISO.LT.13) THEN
  2565. C CALL CHCOUL(ICOTAB(I*(2-NISO/8)))
  2566. CALL CHCOUL(ICOTAB(ISOTA0(I,NISO)))
  2567. ELSE
  2568. Csg CALL CHCOUL(I)
  2569. CALL CHCOUL(ICOTAB(MOD(I,12)+1))
  2570. ENDIF
  2571. IF (I*PDDEC-FAIT.LT. 0.98 ) GOTO 6102
  2572. CALL TRLABL(XHAUT+0.002,PYB,0.,ABCDEF(I:I),1,0.17)
  2573. C valeur seuil
  2574. WRITE (ZONE,FMT='(1PG9.2)') VCHC(I)
  2575. CALL TRLABL(XHAUT+0.1,PYB,0.,ZONE,10,0.17)
  2576. FAIT=I*PDDEC
  2577. ENDIF
  2578. 6102 CONTINUE
  2579. ELSE IF (KDEFOR.NE.0) THEN
  2580. CALL TRLABL(XHAUT+0.,FLOAT(NHAUT),0.,'AMPLITUDE',9,0.17)
  2581. CPM NDEFMX au lieu de 7
  2582. NDEF=MIN(NDEF,NDEFMX)
  2583. NBAS = NHAUT - 1 - NDEF
  2584. DO 6103 I=1,NDEF
  2585. CALL CHCOUL(ICHL(I))
  2586. XXXX = AMPIMP(I)
  2587. IF(AMPIMP(I).GE.XSGRAN/2.) XXXX = VCHC(I)
  2588. WRITE (ZONE,FMT='(1PG9.2)') XXXX
  2589. CALL TRLABL(XHAUT+0.,FLOAT(NBAS+I),0.,ZONE,9,0.17)
  2590. 6103 CONTINUE
  2591. ENDIF
  2592. IF (NISO.NE.0.AND.KDEFOR.NE.0) THEN
  2593. CALL CHCOUL(0)
  2594. CALL TRLABL(0.1,FLOAT(NHAUT-NDEC-3),0.,'AMPLITUDE',9,0.17)
  2595. CALL TRLABL(0.1,FLOAT(NHAUT-NDEC-4),0.,'DEFORMEE ',9,0.17)
  2596. WRITE (ZONE,FMT='(1PG9.2)') SIAMPL
  2597. CALL TRLABL(0.,FLOAT(NHAUT - 6 - NDEC),0.,ZONE,9,0.17)
  2598. ENDIF
  2599. IF (NVECL.NE.0) THEN
  2600. CALL TRBOX(0.75,0.75)
  2601. CALL CHCOUL(0)
  2602. C+++*
  2603. CALL TRLABL(-0.1,FLOAT(NHAUT-NDEC-8),0.,
  2604. & 'COMPOSANTES',11,0.17)
  2605. IF (IFLE.NE.0) THEN
  2606. IF (IFLE.EQ.1) THEN
  2607. CALL TRLABL(-0.1,NHAUT-NDEC-8.75,0.,
  2608. & 'CONTRAINTES',11,0.17)
  2609. ELSE
  2610. CALL TRLABL(0.1,NHAUT-NDEC-8.75,0.,'FISSURES',8,0.17)
  2611. ENDIF
  2612. NBAS = NHAUT - 10 - NDEC - NVECL
  2613. DO I=1,NVECL
  2614. CALL CHCOUL(NVCOL(I))
  2615. ZONE=NVLEG(1,I)
  2616. CALL TRLABL(0.,FLOAT(NBAS+I),0.,ZONE,4,0.17)
  2617. ENDDO
  2618. ELSE
  2619. CALL TRLABL(0.1,NHAUT-NDEC-8.75,0.,'VECTEURS',8,0.17)
  2620. NBAS = NHAUT - 10 - NDEC - NVECL
  2621. DO 6104 I=1,NVECL
  2622. CALL CHCOUL(NVCOL(I))
  2623. IF (IDIM.EQ.2) ZONE=NVLEG(1,I)//NVLEG(2,I)
  2624. IF (IDIM.EQ.3) ZONE=NVLEG(1,I)//NVLEG(2,I)//NVLEG(3,I)
  2625. CALL TRLABL(0.,FLOAT(NBAS+I),0.,ZONE,12,0.17)
  2626. 6104 CONTINUE
  2627. ENDIF
  2628. ENDIF
  2629. INWDS2=INWDS
  2630. INWDS=.FALSE.
  2631. CALL FVALIS(0,IRESU,NHAUT,NISO)
  2632. ENDIF
  2633.  
  2634.  
  2635. C----------------------------------------------------------
  2636. C
  2637. C POST TRAITEMENT DE L'AFFICHAGE : ZOOM,NOM,IMPRESSION ...
  2638. C
  2639. C----------------------------------------------------------
  2640.  
  2641. C
  2642. 6105 CONTINUE
  2643. C AFFICHAGE DES CLES GRAPHIQUES
  2644. C AFFICHAGE DES CLES GRAPHIQUES
  2645. NCASE=10
  2646. LLONG=13
  2647. LEGEND(1)=' Fin trace '
  2648. LEGEND(2)=' Zoom/Pan'
  2649. LEGEND(3)=' Rotation'
  2650. LEGEND(4)=' Coupe '
  2651. LEGEND(5)=' Valeur'
  2652. LEGEND(6)='Qualification'
  2653. LEGEND(7)=' Noeuds'
  2654. LEGEND(8)=' Elements'
  2655. LEGEND(9)=' Animation'
  2656. C attention dans xtrini on teste la chaine " Animation"
  2657. LEGEND(10)=' Options'
  2658.  
  2659. if (idim.ne.3) then
  2660. legend(3)=' '
  2661. legend(4)=' '
  2662. endif
  2663. IF (NISO.NE.0.OR.NDEF.NE.0.OR.NVECL.NE.0) THEN
  2664. LEGEND(6)=' '
  2665. LEGEND(7)=' '
  2666. LEGEND(8)=' '
  2667. IF (KDEFOR.NE.0.OR.IVEC.NE.0) LEGEND(5)=' '
  2668. IF (IANIM.EQ.0) LEGEND(9)=' '
  2669. ELSE
  2670. LEGEND(5)=' '
  2671. LEGEND(9)=' '
  2672. ENDIF
  2673. IF (KDEFOR.NE.0) LEGEND(5)='Amplification'
  2674. IF (NCOMP.NE.0) LEGEND(6)='Composantes'
  2675. CALL MENU(LEGEND,NCASE,LLONG)
  2676. C
  2677. IRESU=0
  2678. C RECUPERATION DE LA CLE FRAPPEE
  2679. icle=-1
  2680. isort=0
  2681. CALL TRAFF(ICLE)
  2682. C TRAITEMENT
  2683. IF (ICLE.NE.0) THEN
  2684. IF (ICLE.EQ.1) THEN
  2685. CALL PRZOOM(IRESU,ISORT,IQUALI,INUMNO,INUMEL,
  2686. $ XMI,XMA,YMI,YMA)
  2687.  
  2688.  
  2689. ENDIF
  2690. IF (ICLE.EQ.2) THEN
  2691. CALL rotvu(ioeini,ioeil,cgrav,xmi,xma,ymi,yma,zmi,zma,axez)
  2692. GOTO 7001
  2693. ENDIF
  2694. IF (ICLE.EQ.4) THEN
  2695. IF (KDEFOR.EQ.0) THEN
  2696. C AFFICHAGE DE VALEUR D'ISO
  2697. PAS=(X2-X1)/(XMA-XMI)
  2698. CALL ISOINT(VCPCHA,MELEME,ICPR,XPROJ,IVU,PAS,
  2699. $ XMI,YMI,X1,Y1,mcham)
  2700. IRESU=2
  2701. GOTO 6101
  2702. ELSE
  2703. C (fdp) Modification de l'amplitude de maniere interactive
  2704. CALL AMPINT(NDEF,VCHC,SDEF,IIMP)
  2705. C (fdp) Dans le cas d'une deformee seule, on garde l'amplification
  2706. C saisie dans le COMMON AMPLIT (voir include CCTRACE)
  2707. C Cette valeur sera re-utilisee au prochain trace d'une
  2708. C deformee seule
  2709. IF (NDEF.EQ.1) THEN
  2710. AMPLIT=REAL(AMPIMP(IIMP))
  2711. SIAMPL=REAL(AMPIMP(IIMP))
  2712. ENDIF
  2713. GOTO 7001
  2714. ENDIF
  2715. ENDIF
  2716. IF (ICLE.EQ.5.AND.NCOMP.NE.0) THEN
  2717. CALL COMPINT(NCOMP,LCOMP,COMPCH)
  2718. GOTO 7001
  2719. ENDIF
  2720. IF (ICLE.EQ.5) CALL CHANG(IRESU,ISORT,IQUALI,3)
  2721. IF (ICLE.EQ.6) CALL CHANG(IRESU,ISORT,INUMNO,4)
  2722. IF (ICLE.EQ.7) CALL CHANG(IRESU,ISORT,INUMEL,5)
  2723. IF (ICLE.EQ.11) THEN
  2724. CALL FLGI
  2725. ISORT=0
  2726. ENDIF
  2727. IF (ICLE.EQ.12) THEN
  2728. CALL IMPR
  2729. ISORT=0
  2730. ENDIF
  2731. C BERTIN: Traitement de la coupe
  2732. IF (ICLE.EQ.3) THEN
  2733. C Ecriture de maniere permanente du barycentre e ICOUP1.
  2734. IF (ZCOM.EQ.0) THEN
  2735. CALL ECROBJ('MAILLAGE',MELEME)
  2736. CALL BARYCE
  2737. CALL LIROBJ('POINT',IBARY,1,IRETOU)
  2738. IREF=(IBARY-1)*(IDIM+1)
  2739. BARY(1)=REAL(XCOOR(IREF+1))
  2740. BARY(2)=REAL(XCOOR(IREF+2))
  2741. BARY(3)=REAL(XCOOR(IREF+3))
  2742. XB= BARY(1)
  2743. YB= BARY(2)
  2744. ZB= BARY(3)
  2745. ZCOM=1
  2746. nbpts=xcoor(/1)/(idim+1)
  2747. nbpts=nbpts+3
  2748. segadj mcoord
  2749. icoup1=nbpts-2
  2750. icoup2=nbpts-1
  2751. icoup3=nbpts
  2752. ENDIF
  2753.  
  2754. XE=REAL( XCOOR((IOEIL-1)*(idim+1)+1) )
  2755. YE=REAL( XCOOR((IOEIL-1)*(idim+1)+2) )
  2756. ZE=REAL( XCOOR((IOEIL-1)*(idim+1)+3) )
  2757. LEGEND(1)=' Retour '
  2758. LEGEND(2)=' Annulation '
  2759. LEGEND(3)=' Position '
  2760.  
  2761. CALL MENU(LEGEND,3,30)
  2762. call trmess('Pour une coupe choisir Position puis la definir')
  2763. CALL TRAFF(ICLE2)
  2764.  
  2765. IF (ICLE2.EQ.0) GOTO 6105
  2766.  
  2767. IF (ICLE2.EQ.1) THEN
  2768. ICOUP=0
  2769. mcou2=0
  2770. mcoup=0
  2771. coupol=-1.
  2772. GOTO 7001
  2773. ENDIF
  2774. call coupno(xmi,xma,ymi,yma,zmi,zma,coupra,coupol)
  2775. if(melemi.ne.0)then
  2776. mcoup=0
  2777. mcou2=0
  2778. meleme=melemi
  2779. endif
  2780. if(melei2.ne.0) melem2=melei2
  2781. icoup=1
  2782. C recherche du min et du max le long de oeil bary
  2783. xb=bary(1)
  2784. yb=bary(2)
  2785. zb=bary(3)
  2786. xm=xb-XE
  2787. ym= yb-YE
  2788. zm= zb-ZE
  2789. oeba=sqrt(xm*xm + ym*ym + zm*zm)
  2790. xm = xm / oeba
  2791. ym=ym/oeba
  2792. zm=zm/oeba
  2793. ipt7=meleme
  2794. ipt3=ipt7
  2795. segact ipt7
  2796. coupma= -1000.*oeba
  2797. coupmi= +1000.*oeba
  2798. do ipa=1,max(1,ipt7.lisous(/1))
  2799. if( ipt7.lisous(/1).ne.0) then
  2800. ipt3=ipt7.lisous(ipa)
  2801. segact ipt3
  2802. endif
  2803. do ipb=1,ipt3.num(/2)
  2804. do ipc=1,ipt3.num(/1)
  2805. iu=ipt3.num(ipc,ipb)*(idim+1)
  2806. xu= real(xcoor(iu-3))
  2807. yu= real(xcoor(iu-2))
  2808. zu= real(xcoor(iu-1))
  2809. dd= xm*(xb-xu) + ym*(yb-yu) +zm*(zb-zu)
  2810. if(coupma.lt.dd ) coupma=dd
  2811. if(coupmi.gt.dd ) coupmi=dd
  2812. enddo
  2813. enddo
  2814. if(ipt7.lisous(/1).ne.0) segdes ipt3
  2815. enddo
  2816. xbn = xb - xm*coupma + xm*coupra*(coupma-coupmi)
  2817. ybn = yb - ym*coupma + ym*coupra*(coupma-coupmi)
  2818. zbn = zb - zm*coupma + zm*coupra*(coupma-coupmi)
  2819. segact,mcoord*MOD
  2820. XCOOR((ICOUP1-1)*(idim+1)+1)=XBn
  2821. XCOOR((ICOUP1-1)*(idim+1)+2)=YBn
  2822. XCOOR((ICOUP1-1)*(idim+1)+3)=ZBn
  2823.  
  2824.  
  2825. if( (abs (XM) + abs(YM)) .ne. 0.) then
  2826. xcoor((icoup2-1)*(idim+1)+1 )= xbn - ym
  2827. xcoor((icoup2-1)*(idim+1)+2 )= ybn + xm
  2828. xcoor((icoup2-1)*(idim+1)+3 )= zbn
  2829. xcoor((icoup3-1)*(idim+1)+1 )= xbn - xm*zm
  2830. xcoor((icoup3-1)*(idim+1)+2 )= ybn - ym*zm
  2831. xcoor((icoup3-1)*(idim+1)+3 )= zbn + xm*xm + ym*ym
  2832. else
  2833. xcoor((icoup2-1)*(idim+1)+1 )= xbn + 1.
  2834. xcoor((icoup2-1)*(idim+1)+2 )= ybn
  2835. xcoor((icoup2-1)*(idim+1)+3 )= zbn
  2836. xcoor((icoup3-1)*(idim+1)+1 )= xbn
  2837. xcoor((icoup3-1)*(idim+1)+2 )= ybn + 1.
  2838. xcoor((icoup3-1)*(idim+1)+3 )= zbn
  2839. endif
  2840. C write(IOIMP,*) ' points definissant la coupe'
  2841. icoy1=(ICOUP1-1)*(idim+1)
  2842. icoy2=(ICOUP2-1)*(idim+1)
  2843. icoy3=(ICOUP3-1)*(idim+1)
  2844. write(IOIMP,fmt='(3(e12.5,2X))')xcoor(icoy1+1),xcoor(icoy1+2)
  2845. $ ,xcoor(icoy1+3)
  2846. write(ioimp,fmt='(3(e12.5,2X))')xcoor(icoy2+1),xcoor(icoy2+2)
  2847. $ ,xcoor(icoy2+3)
  2848. write(ioimp,fmt='(3(e12.5,2X))')xcoor(icoy3+1),xcoor(icoy3+2)
  2849. $ ,xcoor(icoy3+3)
  2850. GOTO 7001
  2851. ENDIF
  2852.  
  2853. IF (ICLE.EQ.9) THEN
  2854. LEGEND(1)= ' Retour '
  2855. LEGEND(2)=' Isovaleurs'
  2856. IF (ZCHAM) THEN
  2857. LEGEND(3)=' (X) Champ'
  2858. ELSE
  2859. LEGEND(3)=' ( ) Champ'
  2860. ENDIF
  2861. IF (ZDATE) THEN
  2862. LEGEND(4)=' (X) Date '
  2863. ELSE
  2864. LEGEND(4)=' ( ) Date '
  2865. ENDIF
  2866. LEGEND(5)=' Fonts >> '
  2867. IF (ICOSC.EQ.1) THEN
  2868. LEGEND(6)='Ecran>> Blanc'
  2869. ELSE IF (ICOSC.EQ.2) THEN
  2870. LEGEND(6)='Ecran>> Noir'
  2871. ENDIF
  2872. LEGEND(7)=' Pos Legende '
  2873. CALL MENU(LEGEND,7,13)
  2874. CALL TRAFF(ICLE2)
  2875. C si on a change la fonte on sort
  2876. if (icle2.eq.7) icle2=0