Télécharger prtrac.eso

Retour à la liste

Numérotation des lignes :

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