Télécharger prtrac.eso

Retour à la liste

Numérotation des lignes :

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