Télécharger sorvtk.eso

Retour à la liste

Numérotation des lignes :

  1. C SORVTK SOURCE PV 20/03/30 21:24:40 10567
  2. C***********************************************************************
  3. C NOM : sorvtk.eso
  4. C DESCRIPTION : Sortie d'objets de type MAILLAGE, CHPOINT et/ou MCHAML
  5. C au format VTK
  6. C REFERENCE : VTK File Formats for VTK Version 4.2, extrait de
  7. C The VTK User's Guide, Kitware
  8. C (www.vtk.org/VTK/img/file-formats.pdf)
  9. C***********************************************************************
  10. C HISTORIQUE : 18/06/2012 : JCARDO : creation de la subroutine
  11. C HISTORIQUE : 20/06/2012 : JCARDO : bug impression ITYEL en BINA
  12. C HISTORIQUE : 16/02/2015 : JCARDO : bug memoire + nouveaux elements
  13. C HISTORIQUE : 09/03/2015 : JCARDO : autre bug memoire
  14. C HISTORIQUE :
  15. C***********************************************************************
  16. C Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  17. C en cas de modification de ce sous-programme afin de faciliter
  18. C la maintenance !
  19. C***********************************************************************
  20. C APPELE PAR : operateur SORTir (prsort.eso)
  21. C***********************************************************************
  22. C ENTREES :: aucune
  23. C SORTIES :: aucune (sur fichiers uniquement)
  24. C***********************************************************************
  25. C SYNTAXE (GIBIANE) :
  26. C
  27. C SORT 'VTK' OBJ1 (MOT1) ... (OBJn) (MOTn)
  28. C (|'FORM'|) (|'AUTO'|) ('TEMP' FLOT1) ('DOUBLE_PRECISION')
  29. C |'BINA'| |'NOUV'|
  30. C |'ZIP' | |'SUIT'|
  31. C |'NPVD'|
  32. C
  33. C avec OBJi = [ MAILi | CHPOi | CHMLi | TABi ]
  34. C
  35. C***********************************************************************
  36. SUBROUTINE SORVTK
  37.  
  38. IMPLICIT INTEGER(I-N)
  39. IMPLICIT REAL*8(A-H,O-Z)
  40.  
  41. -INC CCGEOME
  42.  
  43. -INC PPARAM
  44. -INC CCOPTIO
  45. -INC SMCOORD
  46.  
  47. -INC SMELEME
  48. -INC SMCHPOI
  49. -INC SMCHAML
  50. -INC SMLMOTS
  51. -INC SMTABLE
  52.  
  53. -INC CCNOYAU
  54. -INC CCASSIS
  55. -INC CCFXDR
  56.  
  57. EXTERNAL LONG
  58.  
  59.  
  60. C OCTETS PRE-DEFINIS A ECRIRE DANS LA SECTION <AppendedData>
  61. C ----------------------------------------------------------
  62. C IXDR1=representation decimale BigEndian de la chaIne ' _'
  63. C IXDR2=representation decimale BigEndian du marqueur End-Of-Record
  64. INTEGER IXDR1,IXDR2
  65. DATA IXDR1/538976351/
  66. DATA IXDR2/10/
  67.  
  68.  
  69. C SEGMENTS DE TRAVAIL TEMPORAIRES
  70. C -------------------------------
  71. C SMAIL = donnees sur les maillages lus (pointeur et nom)
  72. C SCHPO = donnees sur les champs par points lus (pointeur et nom)
  73. C SCHML = donnees sur les champs par elements lus (pointeur et nom)
  74. C ICONN,IOFFS,ITYEL = donnees sur les cellules du maillage courant
  75. C IPOL2G|= Tables de correspondance entre la numerotation (globale)
  76. C IPOG2L| des noeuds dans XCOOR et la numerotation (locale) des
  77. C noeuds du maillage dans le fichier .vtu
  78. C IELL2G = Table de correspondance entre la numerotation (globale)
  79. C des cellules du MAILLAGE courant et la numerotation
  80. C (locale) des cellules du MCHAML courant
  81. C ITYPII = donne le sous-maillage forme d'un type donne d'element
  82. C INECUM = donne le nombre cumule d'elements des sous-maillages
  83. C TCHCO = liste des composantes du CHPOINT ou du MCHAML courant
  84. C ICOOK = liste des composantes a sortir (au moins 1 valeur)
  85. C SCHPV = tableau compacte des valeurs du CHPOINT courant
  86. C SCHMV = tableau compacte des valeurs du MCHAML courant
  87.  
  88. SEGMENT SMAIL
  89. CHARACTER*(LONOM) TMAIL(NBMAIL)
  90. INTEGER IMAIL(NBMAIL)
  91. INTEGER IPART(NBMAIL)
  92. INTEGER KMAIL(NBMAIL)
  93. ENDSEGMENT
  94. SEGMENT SCHPO
  95. INTEGER ICHPO(NBCHPO)
  96. CHARACTER*(LONOM) TCHPO(NBCHPO)
  97. ENDSEGMENT
  98. SEGMENT SCHML
  99. INTEGER ICHML(NBCHML)
  100. CHARACTER*(LONOM) TCHML(NBCHML)
  101. ENDSEGMENT
  102.  
  103. SEGMENT IPOL2G(NNO)
  104. SEGMENT IPOG2L(NPMAX)
  105. SEGMENT IELL2G(NEL2)
  106. SEGMENT ICONN(NBCON)
  107. SEGMENT IOFFS(NEL)
  108. SEGMENT ITYEL(NEL1)
  109. SEGMENT ITYPII(NOMBR)
  110. SEGMENT INECUM(NBSOU1)
  111.  
  112. POINTEUR TCHCO.MLMOTS
  113. SEGMENT ICOOK(0)
  114.  
  115. SEGMENT SCHPV
  116. REAL*8 XPOCHA(NCO,NNO)
  117. ENDSEGMENT
  118. SEGMENT SCHMV
  119. REAL*8 XELCHE(NCO,NEL)
  120. ENDSEGMENT
  121.  
  122.  
  123. C MOTS-CLES DE L'OPERATEUR
  124. C ------------------------
  125. PARAMETER(LMCLE=9)
  126. CHARACTER*4 MCLE(LMCLE)
  127. DATA MCLE/'AUTO','SUIT','NOUV','NPVD',
  128. & 'FORM','BINA','ZIP',
  129. & 'TEMP',
  130. & 'DOUB'/
  131.  
  132.  
  133. C VARIABLES BOOLEENNES
  134. C --------------------
  135. C ZEXIS = vrai si le fichier .pvd existe deja (et est compatible)
  136. C ZTEMP = vrai si le pas de temps a ete indique (mot-cle 'TEMP')
  137. C ZPART = vrai si plusieurs maillages ont ete transmis
  138. C ZOPT1,ZOPT2 = utilises pour s'assurer que plusieurs mots-cles
  139. C d'une meme option n'ont pas ete lus
  140. C ZOPEN = vrai si OPTI 'SORT' a bien ete appele au prealable
  141. C ZDOUB = vrai si on ecrit les donnees en double precision
  142. LOGICAL ZEXIS,ZTEMP,ZPART,ZOPT1,ZOPT2,ZOPEN,ZDOUB
  143.  
  144.  
  145. C TABLEAUX DE CORRESPONDANCE entre les elements geometriques de
  146. C CAST3M et ceux de VTK (www.vtk.org/VTK/img/file-formats.pdf)
  147. C --------------------
  148. INTEGER*2 ITYVTK(48)
  149. DATA ITYVTK
  150. C POI1 SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5
  151. . / 1 , 3 , 21 , 5 , 0 , 22 , 34 , 9 , 0 ,
  152. C QUA8 QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3
  153. . 23 , 28 , 0 , 0 , 12 , 25 , 13 , 26 , 0 ,
  154. C LIA4 LIA6 LIA8 MULT TET4 TE10 PYR5 PY13 ATTA
  155. . 0 , 0 , 0 , 0 , 10 , 24 , 14 , 27 , 0 ,
  156. C SUPE RAP3 LIP6 LIP8 POLY CU27 PR21 TE15 PY19
  157. . 0 , 0 , 0 , 0 , 0 , 29 , 0 , 0 , 0 ,
  158. C SEG4 QU16 TR12 PR18 SEG6 TR21 QU36 C216 P126
  159. . 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
  160. C TE56 PY91 SURE
  161. . 0 , 0 , 0 /
  162.  
  163. C Correspondance des numerotations pour les elements quadratiques
  164. INTEGER*2 INUVTK(27, 14)
  165. INTEGER*2 NUSEG3(3), NUTRI6(6), NUQUA8(8),NUTE10(10),NUCU20(20),
  166. . NUPR15(15),NUPY13(13),NUQUA9(9),NUCU27(27),NUTRI7(7)
  167. DATA NUSEG3 / 1, 3, 2 /
  168. DATA NUTRI6 / 1, 3, 5, 2, 4, 6 /
  169. DATA NUQUA8 / 1, 3, 5, 7, 2, 4, 6, 8 /
  170. DATA NUTE10 / 1, 3, 5, 10, 2, 4, 6, 7, 8, 9 /
  171. DATA NUCU20 / 1, 3, 5, 7, 13, 15, 17, 19, 2, 4, 6, 8, 14, 16, 18,
  172. . 20, 9, 10, 11, 12 /
  173. DATA NUPR15 / 1, 3, 5, 10, 12, 14, 2, 4, 6, 11, 13, 15, 7, 8, 9 /
  174. DATA NUPY13 / 1, 3, 5, 7, 13, 2, 4, 6, 8, 9, 10, 11, 12 /
  175. DATA NUQUA9 / 1, 3, 5, 7, 2, 4, 6, 8, 9 /
  176. DATA NUCU27 / 1, 3, 5, 7, 13, 15, 17, 19, 2, 4, 6, 8, 14, 16, 18,
  177. . 20, 9, 10, 11, 12, 24, 22, 21, 23, 25, 26, 27 /
  178. DATA NUTRI7 / 1, 3, 5, 2, 4, 6, 7 /
  179. EQUIVALENCE (INUVTK(1,1 ),NUSEG3(1)),
  180. . (INUVTK(1,2 ),NUTRI6(1)),
  181. . (INUVTK(1,3 ),NUQUA8(1)),
  182. . (INUVTK(1,4 ),NUTE10(1)),
  183. . (INUVTK(1,5 ),NUCU20(1)),
  184. . (INUVTK(1,6 ),NUPR15(1)),
  185. . (INUVTK(1,7 ),NUPY13(1)),
  186. . (INUVTK(1,8 ),NUQUA9(1)),
  187. . (INUVTK(1,9 ),NUCU27(1)),
  188. . (INUVTK(1,14),NUTRI7(1))
  189.  
  190.  
  191. C AUTRES DECLARATIONS
  192. C -------------------
  193.  
  194. C Chaines de caracteres generiques
  195. CHARACTER*4 CHA4
  196. CHARACTER*8 CHA8
  197. CHARACTER*9 CHA9
  198.  
  199. C Chaine de caracteres destinee a recueillir un nom GIBIANE
  200. CHARACTER*(LONOM) CNOM
  201.  
  202. C Chaines de caracteres pour la conversion de nombres
  203. CHARACTER*15 CNU1,CNU2
  204.  
  205. C Variables pour la manipulation des noms de fichiers
  206. CHARACTER*72 NOM1,NOM2,NOM3
  207.  
  208. C Variable pour les formats I/O dynamiques
  209. CHARACTER*30 MYFMT
  210.  
  211. C Buffer utilise lors de la lecture preliminaire du fichier .pvd
  212. CHARACTER*200 CBUF
  213.  
  214. C Ligne de commentaire ecrite en-tete de tous les fichiers
  215. CHARACTER*120 CHEAD
  216.  
  217.  
  218. C *****************************************************************
  219. C CONTROLE DE LA TAILLE ET DE LA PRECISION DES DONNEES NUMERIQUES
  220. C ECRITES SUR LES UNITES DE SORTIE IOXML ET IOBIN
  221. C *****************************************************************
  222. C
  223. C /!\ CHOIX NON MODIFIABLES PAR 'DOUBLE_PRECISION' :
  224. C
  225. C - En BINAire :
  226. C => les connectivites et offsets des cellules sont ecrits sur
  227. C 4 octets, ce qui "limite" le nombre de noeuds a 2 milliards
  228. C => les types des cellules sont codes sur 1 octet (puis groupes
  229. C par 4 pour pouvoir etre ecrits par XDR)
  230. C => Le standard VTK impose que la variable NBYTES ci-dessous
  231. C soit ecrite sur 4 octets (soit ISIZNB=4)
  232. C
  233. C - En FORMate :
  234. C => les CHPOINT et MCHAML sont ecrits sur N colonnes, ou N est
  235. C le nombre de composantes : il y aura une erreur si N est
  236. C un multiple de 100 car N est ecrit au format I2.
  237. C
  238. C ------------------------------
  239.  
  240. C NBYTES=Nombre d'octets ecrits jusqu'alors dans la section AppendedData (hors caractere '_' initial)
  241. C ISIZNB=Taille (en octets) sur laquelle ecrire la variable NBYTES
  242. INTEGER NBYTES
  243. PARAMETER(ISIZNB=4)
  244.  
  245. C Formats numeriques predefinis pour l'ecriture de reels
  246. CHARACTER*8 FMR4,FMR8
  247. PARAMETER(FMR4='E14.6E2 ')
  248. PARAMETER(FMR8='E24.15E3')
  249.  
  250. C Variables a modifier selon la valeur de ZDOUB
  251. C - FMDAT=[FMR4|FMR8]
  252. C - FLDAT=['Float32'|'Float64']
  253. C - ISIZDA=[4|8]
  254. CHARACTER*8 FMDAT
  255. CHARACTER*7 FLDAT
  256. INTEGER ISIZDA
  257.  
  258. C Variables generiques de precision donnee
  259. INTEGER INT8
  260. REAL*4 XRE4,YRE4,ZRE4
  261. REAL*8 XRE8,YRE8,ZRE8
  262.  
  263.  
  264. C (FIN DES DECLARATIONS)
  265. C *****************************************************************
  266. C *****************************************************************
  267.  
  268. C Numero de la sortie logique vers le fichier .vtu
  269. C (le numero de l'eventuel .bin sera renvoye par INITXDR)
  270. IOXML=IOPER
  271.  
  272. C Nombre max. de noeuds (pour dimensionner les tableaux)
  273. IDIM1=IDIM+1
  274. NPMAX=nbpts
  275.  
  276. C Nom de base des fichiers a sortir
  277. INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
  278. IF (.NOT.ZOPEN) THEN
  279. CALL ERREUR(-212)
  280. WRITE(IOIMP,*) '(via OPTI "SORT")'
  281. MOTERR(1:8)='VTK '
  282. CALL ERREUR(705)
  283. RETURN
  284. ENDIF
  285. INQUIRE(UNIT=IOPER,NAME=NOMFIC)
  286. CLOSE(UNIT=IOPER,STATUS='DELETE')
  287. C ---------------------------------------
  288. C /!\ On ferme immediatement le fichier ouvert par OPTI 'SORT'...
  289. C CE N'ETAIT PAS L'APPROCHE GENERALEMENT ADOPTEE quand on utilisait
  290. C l'operateur SORTir, mais ici il devient beaucoup plus commode de
  291. C proceder ainsi, pour plusieurs raisons :
  292. C - eventuellement plusieurs fichiers .vtu seront ecrits
  293. C - le fichier .pvd peut etre ou ne pas etre ecrit
  294. C - les fichiers .vtu peuvent etre en mode ASCII ou BINAIRE
  295. C - il faut rajouter l'extension !
  296. C ---------------------------------------
  297. C UNE AUTRE METHODE PLUS PRAGMATIQUE SERAIT DE RECUPERER LE NOM DE
  298. C BASE DIRECTEMENT EN PREMIER ARGUMENT DE L'OPERATEUR SORT :
  299. C CALL LIRCHA(NOMFIC,1,LNOM1)
  300. C IF (IERR.NE.0) RETURN
  301. C ---------------------------------------
  302.  
  303. C On isole le nom du repertoire dans NOM1, s'il existe
  304. C ON CONSIDERE QUE / ET \ SONT DES SEPARATEURS DE REPERTOIRES
  305. C (C'EST BIEN LE CAS SOUS WINDOWS MAIS PAS SOUS LINUX)
  306. IREP1=INDEX(NOMFIC,'/' ,BACK=.TRUE.)
  307. IREP2=INDEX(NOMFIC,CHAR(92),BACK=.TRUE.)
  308. IREP =MAX(IREP1,IREP2)
  309. NOM1='./'
  310. IF (IREP.GT.0) THEN
  311. NOM1=NOMFIC(1:IREP)
  312. NOMFIC=NOMFIC(IREP+1:LONG(NOMFIC))
  313. ENDIF
  314.  
  315.  
  316.  
  317.  
  318. C***********************************************************************
  319. C***********************************************************************
  320. C***********************************************************************
  321. C***********************************************************************
  322.  
  323.  
  324.  
  325.  
  326. C +---------------------------------------------------------------+
  327. C | |
  328. C | L E C T U R E D E S A R G U M E N T S |
  329. C | |
  330. C +---------------------------------------------------------------+
  331.  
  332.  
  333. C NBMAIL :: nombre d'objets 'MAILLAGE' lus
  334. C NBCHPO :: nombre d'objets 'CHPOINT' lus
  335. C NBCHML :: nombre d'objets 'MCHAML' lus
  336. NBMAIL=0
  337. NBCHPO=0
  338. NBCHML=0
  339. SEGINI,SMAIL,SCHPO,SCHML
  340.  
  341. C IPVD=0 :: option 'AUTO' => completion du .pvd si possible, creation d'un nouveau sinon
  342. C IPVD=1 :: option 'SUIT' => force la completion du .pvd (erreur s'il n'existe pas ou s'il est incompatible)
  343. C IPVD=2 :: option 'NOUV' => force l'ecriture d'un nouveau .pvd
  344. C IPVD=3 :: option 'NPVD' => pas de fichier .pvd
  345. IPVD=0
  346.  
  347. C IVTU=0 :: option 'FORMATE' => ecriture du .vtu en formate (ascii)
  348. C IVTU=1 :: option 'BINAIRE' => ecriture du .vtu en binaire (section AppendedData)
  349. C IVTU=2 :: option 'ZIP' => idem que 'BINA', avec compression zlib en plus
  350. IVTU=1
  351.  
  352. C ZTEMP :: option 'TEMP'
  353. XTPS=0.D0
  354. ZTEMP=.FALSE.
  355.  
  356. C ZDOUB :: option 'DOUBLE_PRECISION'
  357. ZDOUB=.FALSE.
  358. FMDAT=FMR4
  359. FLDAT='Float32'
  360. ISIZDA=4
  361.  
  362. C ZOPT1 evite les ambiguites sur la valeur de IPVD
  363. C ZOPT2 evite les ambiguites sur la valeur de IVTU
  364. ZOPT1=.FALSE.
  365. ZOPT2=.FALSE.
  366.  
  367.  
  368.  
  369. C (branchement vers les etiquettes de lecture d'objets =LIROBJ)
  370. 10 CONTINUE
  371.  
  372. CALL QUETYP(CHA8,0,IRETOU)
  373. IF (IRETOU.EQ.0) GOTO 99
  374.  
  375. ILAB=0
  376. IF (CHA8.EQ.'MAILLAGE') ILAB=1
  377. IF (CHA8.EQ.'CHPOINT' ) ILAB=2
  378. IF (CHA8.EQ.'MCHAML' ) ILAB=3
  379. IF (CHA8.EQ.'TABLE' ) ILAB=4
  380. IF (ILAB.GT.0) GOTO(20,30,40,50),ILAB
  381.  
  382. IF (CHA8.EQ.'MOT') THEN
  383. CALL LIRCHA(CHA4,1,LCHA)
  384. CALL CHRMOT(MCLE,LMCLE,CHA4,ICLE)
  385. IF (ICLE.GT.0) GOTO 11
  386.  
  387. C ERREUR CRITIQUE 7 (On ne comprend pas le mot %m1:4)
  388. MOTERR(1:4)=CHA4
  389. CALL ERREUR(7)
  390. RETURN
  391. ENDIF
  392.  
  393. C ERREUR CRITIQUE 39 (On ne veut pas d'objet de type %m1:8)
  394. MOTERR(1:8)=CHA8
  395. CALL ERREUR(39)
  396. RETURN
  397.  
  398.  
  399.  
  400. C (branchement vers les etiquettes de traitement des mots-cles)
  401. 11 GOTO( 70, 70, 70, 70, 71, 71, 71, 72, 73 ),ICLE
  402. C AUTO SUIT NOUV NPVD FORM BINA ZIP TEMP DOUB
  403.  
  404.  
  405.  
  406. C =============================================
  407. C LECTURE ET MEMORISATION D'UN OBJET 'MAILLAGE'
  408. C =============================================
  409.  
  410. 20 CONTINUE
  411.  
  412. C Lecture d'un nouveau MELEME
  413. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  414. IF (IERR.NE.0) GOTO 999
  415.  
  416. C Verification que le MELEME n'est pas deja dans la liste
  417. DO I1=1,NBMAIL
  418. IF (IMAIL(I1).EQ.IPT1) GOTO 60
  419. ENDDO
  420. NBMAIL=NBMAIL+1
  421.  
  422. C Attribution d'un nom par defaut a l'objet lu
  423. CALL QUENOM(CNOM)
  424. IF (CNOM(1:1).EQ.'#'.OR.CNOM(1:1).EQ.' ')
  425. & WRITE(CNOM,FMT='("MAILLAGE_",I4.4)') NBMAIL
  426. C Memorisation des informations
  427. SEGADJ,SMAIL
  428. IMAIL(NBMAIL)=IPT1
  429. IPART(NBMAIL)=NBMAIL
  430. TMAIL(NBMAIL)=CNOM
  431. KMAIL(NBMAIL)=0
  432.  
  433. GOTO 60
  434.  
  435.  
  436. C ============================================
  437. C LECTURE ET MEMORISATION D'UN OBJET 'CHPOINT'
  438. C ============================================
  439.  
  440. 30 CONTINUE
  441.  
  442. C Lecture d'un nouveau CHPOINT
  443. CALL LIROBJ('CHPOINT',MCHPO1,1,IRETOU)
  444. IF (IERR.NE.0) GOTO 999
  445.  
  446. C Verification que le CHPOINT n'est pas deja dans la liste
  447. DO I1=1,NBCHPO
  448. IF (ICHPO(I1).EQ.MCHPO1) GOTO 60
  449. ENDDO
  450. NBCHPO=NBCHPO+1
  451.  
  452. C Attribution d'un nom par defaut a l'objet lu
  453. CALL QUENOM(CNOM)
  454. IF (CNOM(1:1).EQ.'#'.OR.CNOM(1:1).EQ.' ')
  455. & WRITE(CNOM,FMT='("CHPOINT_",I4.4)') NBCHPO
  456.  
  457. C Memorisation des informations
  458. SEGADJ,SCHPO
  459. ICHPO(NBCHPO)=MCHPO1
  460. TCHPO(NBCHPO)=CNOM
  461.  
  462. GOTO 60
  463.  
  464.  
  465. C ===========================================
  466. C LECTURE ET MEMORISATION D'UN OBJET 'MCHAML'
  467. C ===========================================
  468.  
  469. 40 CONTINUE
  470.  
  471. C Lecture d'un nouveau MCHAML
  472. CALL LIROBJ('MCHAML',MCHEL1,1,IRETOU)
  473. IF (IERR.NE.0) GOTO 999
  474.  
  475. C Verification que le MCHAML n'est pas deja dans la liste
  476. DO I1=1,NBCHML
  477. IF (ICHML(I1).EQ.MCHEL1) GOTO 60
  478. ENDDO
  479. NBCHML=NBCHML+1
  480.  
  481. C Attribution d'un nom par defaut a l'objet lu
  482. CALL QUENOM(CNOM)
  483. IF (CNOM(1:1).EQ.'#'.OR.CNOM(1:1).EQ.' ')
  484. & WRITE(CNOM,FMT='("CHAMELEM_",I4.4)') NBCHML
  485.  
  486. C Memorisation des informations
  487. SEGADJ,SCHML
  488. ICHML(NBCHML)=MCHEL1
  489. TCHML(NBCHML)=CNOM
  490.  
  491. GOTO 60
  492.  
  493.  
  494. C ===========================================
  495. C LECTURE ET DECOMPOSITION D'UN OBJET 'TABLE'
  496. C ===========================================
  497.  
  498. 50 CONTINUE
  499.  
  500. C Lecture d'une TABLE
  501. CALL LIROBJ('TABLE',MTABLE,1,IRETOU)
  502. IF (IERR.NE.0) GOTO 999
  503.  
  504. C Decomposition de la TABLE en objets MAILLAGE, CHPOINT et MCHAML
  505. SEGACT,MTABLE
  506. DO K=MLOTAB,1,-1
  507.  
  508. C Conversion de l'indice en chaine de caracteres
  509. CHA4=MTABTI(K)(1:4)
  510. IF (CHA4.EQ.'ENTI') WRITE(CNOM,FMT='(I8.8)') MTABII(K)
  511. IF (CHA4.EQ.'FLOT') WRITE(CNOM,FMT='(F8.4)') RMTABI(K)
  512. IF (CHA4.EQ.'MOT') THEN
  513. CNOM=' '
  514. IF (NBESC.NE.0) SEGACT IPILOC
  515. IMO1=IPCHAR(MTABII(K))
  516. IMO2=IPCHAR(MTABII(K)+1)
  517. ILON=MIN(LONOM,IMO2-IMO1)
  518. CNOM(1:ILON)=ICHARA(IMO1:IMO1+ILON-1)
  519. IF (NBESC.NE.0) SEGDES,IPILOC
  520. ENDIF
  521.  
  522. C Ecriture du nom puis du pointeur vers l'objet
  523. IF (MTABTV(K).EQ.'MAILLAGE'.OR.
  524. . MTABTV(K).EQ.'CHPOINT'.OR.
  525. . MTABTV(K).EQ.'MCHAML') THEN
  526. CALL ECRCHA(CNOM)
  527. CHA8=MTABTV(K)
  528. IPOB=MTABIV(K)
  529. CALL ECROBJ(CHA8,IPOB)
  530. ELSE
  531. C ERREUR CRITIQUE 763 (Dans la table %m1:8, l'objet d'indice %m9:16 n'est pas de type %m17:40)
  532. CALL QUENOM(CHA8)
  533. MOTERR(1:8)=CHA8
  534. WRITE(MOTERR(9:16),FMT='("n=",I6)') K
  535. MOTERR(17:40)=' MAILLAGE/CHPOINT/MCHAML'
  536. CALL ERREUR(763)
  537. RETURN
  538. ENDIF
  539. ENDDO
  540. SEGDES,MTABLE
  541.  
  542. GOTO 10
  543.  
  544.  
  545. C ========================================
  546. C ATTRIBUTION D'UN NOM AU DERNIER OBJET LU
  547. C ========================================
  548.  
  549. 60 CONTINUE
  550.  
  551. CALL QUETYP(CHA8,0,IRETOU)
  552. IF (IRETOU.NE.0.AND.CHA8.EQ.'MOT') THEN
  553. CALL LIRCHA(CNOM,0,LCHA)
  554. CALL CHRMOT(MCLE,LMCLE,CNOM,ICLE)
  555. IF (ICLE.GT.0) GOTO 11
  556. C Remarque : On utilise le fait que I1 est incremente au passage sur ENDDO
  557. C Ainsi, I1 reste fige si on sort prematurement, et vaut bien N+1
  558. C si les N iterations se sont deroulees sans encombre
  559. IF (ILAB.EQ.1) TMAIL(I1)=CNOM
  560. IF (ILAB.EQ.2) TCHPO(I1)=CNOM
  561. IF (ILAB.EQ.3) TCHML(I1)=CNOM
  562. IF (ILAB.EQ.4) THEN
  563. CALL ERREUR(880)
  564. RETURN
  565. ENDIF
  566. ENDIF
  567.  
  568. GOTO 10
  569.  
  570.  
  571. C ====================
  572. C LECTURE D'UN MOT-CLE
  573. C ====================
  574.  
  575. C Mots-cles 'AUTO, 'NOUV', 'SUIT' ou 'NPVD'
  576. 70 CONTINUE
  577. ICLE1=ICLE-1
  578. IF (ZOPT1.AND.IPVD.NE.ICLE1) THEN
  579. C ERREUR CRITIQUE 880 (Syntaxe incorrecte, voir notice)
  580. CALL ERREUR(880)
  581. WRITE(IOIMP,*) '(options ',MCLE(IPVD),' et ',MCLE(ICLE),
  582. . ' incompatibles)'
  583. RETURN
  584. ENDIF
  585. ZOPT1=.TRUE.
  586. IPVD=ICLE1
  587. GOTO 10
  588.  
  589. C Mots-cles 'FORM, 'BINA' ou 'ZIP'
  590. 71 CONTINUE
  591. ICLE1=ICLE-5
  592. IF (ZOPT2.AND.IVTU.NE.ICLE1) THEN
  593. C ERREUR CRITIQUE 880 (Syntaxe incorrecte, voir notice)
  594. CALL ERREUR(880)
  595. WRITE(IOIMP,*) '(options ',MCLE(IVTU+4),' et ',MCLE(ICLE),
  596. . ' incompatibles)'
  597. RETURN
  598. ENDIF
  599. ZOPT2=.TRUE.
  600. IVTU=ICLE1
  601.  
  602. IF (IVTU.EQ.2) THEN
  603. C ERREUR CRITIQUE 251 (Tentative d'utilisation d'une option non implementee)
  604. CALL ERREUR(251)
  605. WRITE(IOIMP,*) '(option ZIP indisponible pour le moment)'
  606. RETURN
  607. ENDIF
  608. GOTO 10
  609.  
  610. C Mot-cle 'TEMP'
  611. 72 CONTINUE
  612. ZTEMP=.TRUE.
  613. CALL LIRREE(XTPS,0,IRETOU)
  614. IF (IRETOU.EQ.0) THEN
  615. C ERREUR CRITIQUE 166 (Le mot-cle %m1:4 n'est pas suivi de la donnee correspondante)
  616. MOTERR(1:4)='TEMP'
  617. CALL ERREUR(166)
  618. RETURN
  619. ENDIF
  620. GOTO 10
  621.  
  622. C Mot-cle 'DOUB'
  623. 73 CONTINUE
  624. ZDOUB=.TRUE.
  625. FMDAT=FMR8
  626. FLDAT='Float64'
  627. ISIZDA=8
  628. GOTO 10
  629.  
  630.  
  631.  
  632.  
  633. 99 CONTINUE
  634.  
  635.  
  636. C Verification : il faut au moins 1 objet MAILLAGE pour continuer
  637. IF (NBMAIL.EQ.0) THEN
  638. C ERREUR CRITIQUE 37 (On ne trouve pas d'objet de type %m1:8)
  639. MOTERR(1:8)='MAILLAGE'
  640. CALL ERREUR(37)
  641. RETURN
  642. ENDIF
  643.  
  644. C Il y a-t-il plusieurs objets MAILLAGE ?
  645. ZPART=(NBMAIL.GT.1)
  646.  
  647.  
  648.  
  649. C IMPRESSIONS POUR DEBOGAGE
  650. C #########################
  651. IF (IIMPI.NE.0) THEN
  652. WRITE(IOIMP,FMT='(I2,A)') NBMAIL,' MAILLAGE(s) lu(s)'
  653. WRITE(IOIMP,FMT='(5X,I7,2X,A24)') (IMAIL(I),TMAIL(I),I=1,NBMAIL)
  654.  
  655. WRITE(IOIMP,FMT='(I2,A)') NBCHPO,' CHPOINT(s) lu(s)'
  656. WRITE(IOIMP,FMT='(5X,I7,2X,A24)') (ICHPO(I),TCHPO(I),I=1,NBCHPO)
  657.  
  658. WRITE(IOIMP,FMT='(I2,A)') NBCHML,' MCHAML(s) lu(s)'
  659. WRITE(IOIMP,FMT='(5X,I7,2X,A24)') (ICHML(I),TCHML(I),I=1,NBCHML)
  660. ENDIF
  661. C #########################
  662.  
  663.  
  664.  
  665.  
  666. C***********************************************************************
  667. C***********************************************************************
  668. C***********************************************************************
  669. C***********************************************************************
  670.  
  671.  
  672.  
  673.  
  674. C +---------------------------------------------------------------+
  675. C | |
  676. C | V E R I F I C A T I O N S D A N S L E . P V D |
  677. C | |
  678. C +---------------------------------------------------------------+
  679.  
  680.  
  681. NOM3=NOM1(1:LONG(NOM1))//NOMFIC(1:LONG(NOMFIC))//'.pvd'
  682.  
  683. INQUIRE(FILE=NOM3,EXIST=ZEXIS)
  684.  
  685.  
  686. C Option 'AUTO' ou 'SUIT' : on verifie que le .pvd pre-existant
  687. C est compatible avec les donnees que l'on veut rajouter
  688. C (cette verification n'a pas vocation a etre infaillible, elle
  689. C permet seulement d'eviter aux etourdis de corrompre le .pvd)
  690. C
  691. C Apres lecture du .pvd : ITF=dernier indice enregistre
  692. C XTF=dernier instant enregistre
  693. ITF=0
  694. IF (IPVD.LT.2.AND.ZEXIS) THEN
  695. OPEN(UNIT = IOXML ,
  696. . FILE = NOM3 ,
  697. . STATUS = 'OLD' ,
  698. . FORM = 'FORMATTED' ,
  699. . ACCESS = 'SEQUENTIAL',
  700. . IOSTAT = IOS )
  701. CALL FINFIC(IOXML)
  702.  
  703.  
  704. C On remonte au-dela des balises de fermeture du .pvd
  705. DO NLFOOTER=1,5
  706. BACKSPACE(IOXML)
  707. READ(UNIT=IOXML,FMT='(A)') CBUF
  708. BACKSPACE(IOXML)
  709. IF (INDEX(CBUF,'</Collection>').GT.0) GOTO 150
  710. ENDDO
  711. GOTO 9004
  712.  
  713. 150 CONTINUE
  714.  
  715.  
  716. C a) Si 'TEMP' est specifie, on verifie que le .pvd contient un
  717. C champ 'timestep' et que la chronologie est respectee. Si en
  718. C outre plusieurs maillages sont fournis, on verifie que la
  719. C partition est identique (verif. du nom et du nombre seult.)
  720.  
  721. IF (ZTEMP) THEN
  722.  
  723. C On va devoir verifier les NBMAIL derniers items
  724. DO I1=1,NBMAIL
  725. BACKSPACE(IOXML)
  726. ENDDO
  727.  
  728. DO IMAI=1,NBMAIL
  729.  
  730. C Lecture de l'item puis recherche des champs 'timestep', 'part', 'name' et 'file'
  731. READ(UNIT=IOXML,FMT='(A)') CBUF
  732. II1=INDEX(CBUF,'timestep=')
  733. II2=INDEX(CBUF,'part=')
  734. II3=INDEX(CBUF,'name=')
  735. II4=INDEX(CBUF,'file="'//NOMFIC(1:LONG(NOMFIC)))
  736.  
  737.  
  738. C DECLENCHEMENT D'UNE ERREUR SI :
  739.  
  740. C - le champ 'file' ne contient pas le nom du fichier lu => 9004
  741. IF (II4.EQ.0) GOTO 9004
  742.  
  743. C - les NBMAIL derniers items n'ont pas le meme 'timestep' => 9001
  744. C - pas de champ 'timestep' trouve => 9002
  745. C - le 'timestep' lu est superieur a la valeur specifiee dans 'TEMP' => 9003
  746. C - le format du fichier n'est pas reconnu => 9004
  747. IF (II1.GT.0) THEN
  748. WRITE(MYFMT,FMT='("(",A8,")")') FMDAT
  749. II5=II1+INDEX(CBUF(II1+10:),'"')+8
  750. READ(CBUF(II1+10:II5),FMT=MYFMT,IOSTAT=IOS) XTF
  751. IF (IOS.NE.0) GOTO 9004
  752. IF (IMAI.GT.1.AND.XTF1.NE.XTF) GOTO 9001
  753. IF (XTF.GE.XTPS) GOTO 9003
  754. XTF1=XTF
  755. ELSE
  756. GOTO 9002
  757. ENDIF
  758.  
  759. C - un seul maillage specifie alors qu'on a trouve un champ 'part' => 9001
  760. C - plusieurs maillages specifies alors qu'on ne trouve aucun champ 'part' => 9001
  761. C - le i-eme champ 'part' n'a pas le meme nom que le i-eme maillage specifie => 9001
  762. C - pas de champ 'name' associe au champ 'part' => 9004
  763. C - le format du fichier n'est pas reconnu => 9004
  764. JPART=1
  765. IF (ZPART.AND.(II2.GT.0)) THEN
  766. IF (II3.EQ.0) GOTO 9004
  767. READ(CBUF(II2+6:II3-3),FMT='(A4)',IOSTAT=IOS) CHA4
  768. IF (IOS.NE.0) GOTO 9004
  769. READ(CHA4,FMT='(I4)',IOSTAT=IOS) JPART
  770. IF (IOS.NE.0) GOTO 9004
  771. IF (JPART.GT.NBMAIL) GOTO 9001
  772. WRITE(MYFMT,FMT='("(A",I2,")")') LONOM
  773. CNOM=CBUF(II3+6:)
  774. II5=INDEX(CNOM,'"')
  775. IF (II5.GT.0) CNOM=CNOM(1:II5-1)
  776. IF (CNOM.NE.TMAIL(JPART)) GOTO 9001
  777. ELSEIF (ZPART.OR.(II2.GT.0)) THEN
  778. GOTO 9001
  779. ENDIF
  780. KMAIL(JPART)=1
  781.  
  782. ENDDO
  783.  
  784. C - un des maillages specifies n'etait pas present dans les fichiers .vtu => 9001
  785. DO IMAI=1,NBMAIL
  786. IF (KMAIL(IMAI).EQ.0) GOTO 9001
  787. ENDDO
  788.  
  789.  
  790. C PAS D'ERREUR : on recupere l'indice du dernier p.d.t.
  791. CALL LENCHA(NOMFIC,NC)
  792. READ(CBUF(II4+NC+7:II4+NC+15),FMT='(A9)',IOSTAT=IOS) CHA9
  793. II4=INDEX(CHA9,'.')-1
  794. WRITE(MYFMT,FMT='("(I",I1,".",I1,")")',IOSTAT=IOS) II4,II4
  795. READ(CHA9(1:II4),FMT=MYFMT,IOSTAT=IO3) ITF
  796. IF (IOS.NE.0.OR.IO3.NE.0.OR.II4.EQ.-1) GOTO 9004
  797.  
  798.  
  799. C b) Si 'TEMP' est absent, on verifie que le .pvd ne contient pas de
  800. C champ 'timestep' mais uniquement un champ 'part' et un champ 'name'
  801. ELSE
  802.  
  803. C Lecture du dernier item puis recherche des champs 'timestep', 'part' et 'name'
  804. BACKSPACE(IOXML)
  805. READ(UNIT=IOXML,FMT='(A)') CBUF
  806. II1=INDEX(CBUF,'timestep=')
  807. II2=INDEX(CBUF,'part=')
  808. II3=INDEX(CBUF,'name=')
  809.  
  810. C DECLENCHEMENT D'UNE ERREUR SI :
  811. C - un champ 'timestep' est trouve => 9005
  812. C - 'timestep' est absent mais 'part' et/ou 'name' manquent => 9004
  813. IF (II1.GT.0) GOTO 9005
  814. IF (II2.EQ.0.OR.II3.EQ.0) GOTO 9004
  815.  
  816. C On retient le numero de la derniere 'part' creee
  817. C et on incremente les futures partitions en consequence
  818. READ(CBUF(II2+6:II3-3),FMT='(A4)',IOSTAT=IOS) CHA4
  819. IF (IOS.NE.0) GOTO 9004
  820. READ(CHA4,FMT='(I4)',IOSTAT=IOS) OLDPAR
  821. IF (IOS.NE.0) GOTO 9004
  822. DO IMAI=1,NBMAIL
  823. IPART(IMAI)=IPART(IMAI)+OLDPAR
  824. ENDDO
  825.  
  826. ENDIF
  827.  
  828. CLOSE(UNIT=IOXML)
  829. ENDIF
  830.  
  831.  
  832. C Pas d'erreur => on passe a la suite
  833. GOTO 9000
  834.  
  835.  
  836. C MESSAGES D'ERREUR : fichier .pvd incompatible et option 'SUIT'
  837. C ***************************************************************
  838. C ERREUR CRITIQUE 26 (Tache impossible. Probablement donnees erronees)
  839.  
  840. 9001 CONTINUE
  841. IF (IPVD.EQ.0) GOTO 9050
  842. CALL ERREUR(26)
  843. WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe deja et la ',
  844. . 'partition specifiee differe du p.d.t. precedent'
  845. GOTO 999
  846.  
  847. 9002 CONTINUE
  848. IF (IPVD.EQ.0) GOTO 9050
  849. CALL ERREUR(26)
  850. WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe deja et ',
  851. . 'n''est pas compatible avec l''option ''TEMP'''
  852. GOTO 999
  853.  
  854. 9003 CONTINUE
  855. IF (IPVD.EQ.0) GOTO 9050
  856. CALL ERREUR(26)
  857. WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe deja et la ',
  858. . 'valeur specifiee pour ''TEMP'' est trop petite'
  859. GOTO 999
  860.  
  861. 9004 CONTINUE
  862. ZEXIS=.FALSE.
  863. IF (IPVD.EQ.0) GOTO 9050
  864. CALL ERREUR(26)
  865. WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe deja mais ',
  866. . 'il semble corrompu...'
  867. GOTO 999
  868.  
  869. 9005 CONTINUE
  870. IF (IPVD.EQ.0) GOTO 9050
  871. CALL ERREUR(26)
  872. WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe deja et ',
  873. . 'requiert l''utilisation du mot-cle ''TEMP'''
  874. GOTO 999
  875. C ***************************************************************
  876.  
  877.  
  878. C Fichier .pvd incompatible et option 'AUTO'
  879. C => on continue mais le .pvd existant sera ecrase
  880. 9050 ZEXIS=.FALSE.
  881.  
  882.  
  883.  
  884.  
  885. C***********************************************************************
  886. C***********************************************************************
  887. C***********************************************************************
  888. C***********************************************************************
  889.  
  890.  
  891.  
  892.  
  893. C +---------------------------------------------------------------+
  894. C | |
  895. C | E C R I T U R E D E S F I C H I E R S . V T U |
  896. C | |
  897. C +---------------------------------------------------------------+
  898.  
  899. 9000 CONTINUE
  900.  
  901. C Lorsqu'il y a deja deux unites logiques XDR ouvertes (REST et
  902. C SAUV en l'occurence), l'ouverture d'une troisieme unite engendre
  903. C un bug critique (redemarrage du jeu de donnees !). On s'assure
  904. C que le fichier de RESTitution est bien ferme pour eviter cela.
  905. IF (IVTU.GT.0.AND.IXDRR.NE.0) THEN
  906. IOS= IXDRCLOSE(IXDRR)
  907. IXDRR=0
  908. ENDIF
  909.  
  910.  
  911. C Preparation de l'entete des fichiers
  912. CALL GIBDAT(IJOUR,IMOIS,IANNEE)
  913. IANNEE=MOD(IANNEE,100)+2000
  914. CALL GIBNAM(CHA8)
  915. CALL NETCHA(CHA8)
  916. WRITE(CHEAD,FMT='(A,I2.2,A1,I2.2,A1,I4,A)')
  917. . '<!-- PROGRAMME=CASTEM/SORVTK'//
  918. . ' UTILISATEUR='//CHA8(1:LONG(CHA8))//
  919. . ' DATE=',IJOUR,'/',IMOIS,'/',IANNEE,
  920. . ' TITRE='//NOMFIC(1:LONG(NOMFIC))//' -->'
  921. CALL LENCHA(CHEAD,LHEAD)
  922.  
  923.  
  924. C ---------------------
  925. C NOM DES FICHIERS .vtu
  926. C ---------------------
  927. C
  928. C repetoire/ nom_de_base.XXXXxxxxx.YYYY.vtu
  929. C |__________||___________|
  930. C NOM1 NOMFIC |
  931. C |_____________________| |
  932. C NOM2 |
  933. C |______________________________|
  934. C NOM3
  935. C
  936. C - XXXXxxxx : /!\ SEULEMENT SI L'OPTION 'TEMP' EST PRESENTE
  937. C => entier ecrit sur 4 a 9 caracteres et incremente
  938. C a chaque pas de temps sorti
  939. C
  940. C - YYYY : /!\ SEULMENT SI PLUSIEURS MAILLAGES SONT FOURNIS
  941. C OU SI ON SORT UN .PVD SANS OPTION 'TEMP'
  942. C => entier ecrit sur 4 caracteres indiquant l'indice
  943. C de la partition geometrie sortie
  944. C
  945. NOM2=NOMFIC
  946. IF (ZTEMP) THEN
  947. IPDT=ITF+1
  948. WRITE(CHA9,FMT='(I9.9)') IPDT
  949. LPDT=MAX(4,INT(LOG10(DBLE(IPDT)))+1)
  950. NOM2=NOM2(1:LONG(NOM2))//'.'//CHA9(10-LPDT:9)
  951. ENDIF
  952.  
  953.  
  954. C (BOUCLE SUR LES MAILLAGES)
  955. DO 100 IMAI=1,NBMAIL
  956.  
  957. C =============================================================
  958. C I N I T I A L I S A T I O N D U F I C H I E R . V T U
  959. C =============================================================
  960.  
  961. C Determination du nom complet du fichier .vtu
  962. NOM3=NOM1(1:LONG(NOM1))//NOM2
  963. IF ((.NOT.ZTEMP.AND.IPVD.LT.3).OR.ZPART) THEN
  964. WRITE(CHA4,FMT='(I4.4)') IPART(IMAI)
  965. NOM3=NOM3(1:LONG(NOM3))//'.'//CHA4
  966. ENDIF
  967. NOM3=NOM3(1:LONG(NOM3))//'.vtu'
  968.  
  969.  
  970. C Commande d'ouverture du fichier XML
  971. OPEN(UNIT = IOXML,
  972. . FILE = NOM3,
  973. . STATUS = 'UNKNOWN',
  974. . FORM = 'FORMATTED',
  975. . ACCESS = 'SEQUENTIAL',
  976. . IOSTAT = IOS)
  977.  
  978.  
  979. C Commande d'ouverture du fichier binaire
  980. IF (IVTU.GT.0) THEN
  981. IOBIN=INITXDR(NOM3(1:LONG(NOM3))//'.bin','w',.FALSE.)
  982.  
  983. C Debut de la section binaire AppendedData
  984. IOS= IXDRINT(IOBIN,IXDR1)
  985. IPOS=0
  986. ENDIF
  987.  
  988.  
  989. C Ecriture des entetes
  990. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  991. . '<?xml version="1.0"?>'
  992.  
  993. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  994. . CHEAD(1:LHEAD)
  995.  
  996. IF (IVTU.EQ.0) THEN
  997. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  998. . '<VTKFile type="UnstructuredGrid" version="0.1">'
  999. ELSE
  1000. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1001. . '<VTKFile type="UnstructuredGrid" version="0.1"'//
  1002. . ' byte_order="BigEndian">'
  1003. ENDIF
  1004.  
  1005. WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS)
  1006. . '<UnstructuredGrid>'
  1007.  
  1008.  
  1009.  
  1010.  
  1011. C =============================================================
  1012. C D O N N E E S G E O M E T R I Q U E S
  1013. C =============================================================
  1014. C NEL = nombre d'elements du maillage au total
  1015. C NNO = nombre de noeuds du maillage au total
  1016. C NBSOU = nombre de sous-maillages (un par type d'element)
  1017.  
  1018. IPT1=IMAIL(IMAI)
  1019. SEGACT,IPT1
  1020. NBSOU=IPT1.LISOUS(/1)
  1021. NBSOU1=MAX(1,NBSOU)
  1022.  
  1023. C Pour chaque MAILLAGE passe en argument, on doit :
  1024. C - remplir les tables de correspondance LOCAL <--> GLOBAL
  1025. C - determiner le nombre de noeuds au total
  1026. C - determiner le nombre d'elements au total
  1027. C - memoriser les caracteristiques des cellules (connectivite,
  1028. C offset, type d'element VTK)
  1029. C - si des MCHAML sont a sortir, memoriser le type et le nombre
  1030. C d'elements dans chaque sous-maillage
  1031.  
  1032. NEL=0
  1033. NEL1=0
  1034. NNO=0
  1035. NBCON=0
  1036. IOF=0
  1037. SEGINI,IPOG2L,IOFFS,ITYEL,ICONN
  1038. IF (NBCHML.GT.0) SEGINI,ITYPII,INECUM
  1039.  
  1040. C (BOUCLE SUR LES SOUS-MAILLAGES)
  1041. IPT2=IPT1
  1042. DO ISOU=1,NBSOU1
  1043. IF (NBSOU.GT.0) THEN
  1044. IPT2=IPT1.LISOUS(ISOU)
  1045. SEGACT,IPT2
  1046. ENDIF
  1047.  
  1048. C L'element est-il representable par VTK ?
  1049. ITYP=IPT2.ITYPEL
  1050. ITY=ITYVTK(ITYP)
  1051. IF (ITY.EQ.0) THEN
  1052. C ERREUR CRITIQUE 21 (Donnees incompatibles)
  1053. CALL ERREUR(21)
  1054. WRITE(IOIMP,*) 'Le maillage ',TMAIL(IMAI),
  1055. . ' comporte des elements ',NOMS(ITYP),
  1056. . ' incompatibles avec VTK'
  1057. GOTO 999
  1058. ENDIF
  1059.  
  1060. C On memorise les infos ci-dessous pour aller plus vite
  1061. C lors du traitement ulterieur des MCHAML
  1062. IF (NBCHML.GT.0) THEN
  1063. ITYPII(ITYP)=ISOU
  1064. INECUM(ISOU)=NEL
  1065. ENDIF
  1066.  
  1067. C (BOUCLE SUR LES ELEMENTS DU SOUS-MAILLAGE)
  1068. NN1=IPT2.NUM(/1)
  1069. NN2=IPT2.NUM(/2)
  1070. NEL=NEL+NN2
  1071. NEL1=NEL
  1072. NBCON=NBCON+(NN1*NN2)
  1073. SEGADJ,ICONN,IOFFS,ITYEL
  1074.  
  1075. DO I2=1,NN2
  1076. DO I1=1,NN1
  1077. IF (ITY.GE.20) THEN
  1078. C Correction pour les elements quadratiques
  1079. I3 = INUVTK(I1,ITY-20)
  1080. ELSE
  1081. I3 = I1
  1082. ENDIF
  1083. INUM=IPT2.NUM(I3,I2)
  1084. IPOG2L(INUM)=1
  1085. ICONN(IOF+I1)=INUM
  1086. ENDDO
  1087. IOF=IOF+NN1
  1088. IOFFS(NEL-NN2+I2)=IOF
  1089. ITYEL(NEL-NN2+I2)=ITY
  1090. ENDDO
  1091.  
  1092. IF (NBSOU.GT.0) SEGDES,IPT2
  1093. ENDDO
  1094.  
  1095.  
  1096. C (BOUCLE SUR LA TABLE GLOBALE IPOG2L)
  1097. NNO=NBCON
  1098. SEGINI,IPOL2G
  1099. NNO=0
  1100. DO I3=1,NPMAX
  1101. IF (IPOG2L(I3).EQ.1) THEN
  1102. NNO=NNO+1
  1103. IPOL2G(NNO)=I3
  1104. IPOG2L(I3)=NNO
  1105. ENDIF
  1106. ENDDO
  1107. IF (NNO.NE.NBCON) SEGADJ,IPOL2G
  1108.  
  1109. c
  1110.  
  1111.  
  1112. C ECRITURE DANS LE FICHIER
  1113. C *************************************************************
  1114. C *************************************************************
  1115.  
  1116. WRITE(CNU1,FMT='(I15)') NNO
  1117. WRITE(CNU2,FMT='(I15)') NEL
  1118. CALL LIMCHA(CNU1,ID1,IF1)
  1119. CALL LIMCHA(CNU2,ID2,IF2)
  1120. WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS)
  1121. . '<Piece NumberOfPoints="'//CNU1(ID1:IF1)//
  1122. . '" NumberOfCells="'//CNU2(ID2:IF2)//'">'
  1123.  
  1124.  
  1125.  
  1126. C *****************************************************
  1127. C S E C T I O N P O I N T S
  1128. C *****************************************************
  1129.  
  1130. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1131. . '<Points>'
  1132.  
  1133. C ===================== FORMATE =====================
  1134. IF (IVTU.EQ.0) THEN
  1135. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1136. . '<DataArray type="'//FLDAT//'" NumberOfComponents="3" '//
  1137. . 'format="ascii">'
  1138.  
  1139. DO IK=1,NNO
  1140. II=IPOL2G(IK)-1
  1141.  
  1142. XRE8=XCOOR(II*IDIM1+1)
  1143. YRE8=XCOOR(II*IDIM1+2)
  1144. ZRE8=0.D0
  1145. IF (IDIM.EQ.3) ZRE8=XCOOR(II*IDIM1+3)
  1146.  
  1147. WRITE(MYFMT,FMT='("(20X,3",A8,")")') FMDAT
  1148. WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS)
  1149. . XRE8,YRE8,ZRE8
  1150. ENDDO
  1151.  
  1152. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1153. . '</DataArray>'
  1154.  
  1155.  
  1156. C ===================== BINAIRE =====================
  1157. ELSE
  1158.  
  1159. NBYTES=(3*NNO)*ISIZDA
  1160.  
  1161. WRITE(CNU1,FMT='(I15)') IPOS
  1162. IPOS=IPOS+ISIZNB+NBYTES
  1163.  
  1164. CALL LIMCHA(CNU1,ID1,IF1)
  1165. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1166. . '<DataArray type="'//FLDAT//'" NumberOfComponents="3" '//
  1167. . 'format="appended" offset="'//CNU1(ID1:IF1)//'" />'
  1168.  
  1169. IOS= IXDRINT(IOBIN,NBYTES)
  1170.  
  1171. IF (ZDOUB) THEN
  1172. DO IK=1,NNO
  1173. II=IPOL2G(IK)-1
  1174.  
  1175. XRE8=XCOOR(II*IDIM1+1)
  1176. YRE8=XCOOR(II*IDIM1+2)
  1177. ZRE8=0.D0
  1178. IF (IDIM.EQ.3) ZRE8=XCOOR(II*IDIM1+3)
  1179.  
  1180. IOS= IXDRDOUBLE(IOBIN,XRE8)
  1181. IOS= IXDRDOUBLE(IOBIN,YRE8)
  1182. IOS= IXDRDOUBLE(IOBIN,ZRE8)
  1183. ENDDO
  1184. ELSE
  1185. DO IK=1,NNO
  1186. II=IPOL2G(IK)-1
  1187.  
  1188. XRE4=REAL(XCOOR(II*IDIM1+1),4)
  1189. YRE4=REAL(XCOOR(II*IDIM1+2),4)
  1190. ZRE4=REAL(0.D0)
  1191. IF (IDIM.EQ.3) ZRE4=REAL(XCOOR(II*IDIM1+3),4)
  1192.  
  1193. IOS= IXDRREAL(IOBIN,XRE4)
  1194. IOS= IXDRREAL(IOBIN,YRE4)
  1195. IOS= IXDRREAL(IOBIN,ZRE4)
  1196. ENDDO
  1197. ENDIF
  1198.  
  1199. ENDIF
  1200.  
  1201. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1202. . '</Points>'
  1203.  
  1204.  
  1205. C *****************************************************
  1206. C S E C T I O N C E L L S
  1207. C *****************************************************
  1208.  
  1209. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1210. . '<Cells>'
  1211.  
  1212. C ===================== FORMATE =====================
  1213. IF (IVTU.EQ.0) THEN
  1214. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1215. . '<DataArray type="Int32" Name="connectivity" '//
  1216. . 'format="ascii">'
  1217.  
  1218. WRITE(UNIT=IOXML,FMT='(20X,8I10)',IOSTAT=IOS)
  1219. . ((IPOG2L(ICONN(K))-1),K=1,ICONN(/1))
  1220.  
  1221. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1222. . '</DataArray>'
  1223.  
  1224. C ----------------------
  1225.  
  1226. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1227. . '<DataArray type="Int32" Name="offsets" format="ascii">'
  1228.  
  1229. WRITE(UNIT=IOXML,FMT='(20X,8I10)',IOSTAT=IOS)
  1230. . (IOFFS(K),K=1,NEL)
  1231.  
  1232. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1233. . '</DataArray>'
  1234.  
  1235. C ----------------------
  1236.  
  1237. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1238. . '<DataArray type="UInt8" Name="types" format="ascii">'
  1239.  
  1240. WRITE(UNIT=IOXML,FMT='(20X,20I4)',IOSTAT=IOS)
  1241. . (ITYEL(K),K=1,NEL)
  1242.  
  1243. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1244. . '</DataArray>'
  1245.  
  1246.  
  1247. C ===================== BINAIRE =====================
  1248. ELSE
  1249. NBYTES=ICONN(/1)*4
  1250.  
  1251. WRITE(CNU1,FMT='(I15)') IPOS
  1252. IPOS=IPOS+ISIZNB+NBYTES
  1253.  
  1254. CALL LIMCHA(CNU1,ID1,IF1)
  1255. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1256. . '<DataArray type="Int32" Name="connectivity" '//
  1257. . 'format="appended" offset="'//CNU1(ID1:IF1)//'" />'
  1258.  
  1259. IOS= IXDRINT(IOBIN,NBYTES)
  1260.  
  1261. DO K=1,ICONN(/1)
  1262. INT8=IPOG2L(ICONN(K))-1
  1263. IOS=IXDRINT(IOBIN,INT8)
  1264. ENDDO
  1265.  
  1266. C ----------------------
  1267.  
  1268. NBYTES=NEL*4
  1269.  
  1270. WRITE(CNU1,FMT='(I15)') IPOS
  1271. IPOS=IPOS+ISIZNB+NBYTES
  1272.  
  1273. CALL LIMCHA(CNU1,ID1,IF1)
  1274. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1275. . '<DataArray type="Int32" Name="offsets" '//
  1276. . 'format="appended" offset="'//CNU1(ID1:IF1)//'" />'
  1277.  
  1278. IOS=IXDRINT(IOBIN,NBYTES)
  1279.  
  1280. DO K=1,NEL
  1281. INT8=IOFFS(K)
  1282. IOS=IXDRINT(IOBIN,INT8)
  1283. ENDDO
  1284.  
  1285. C ----------------------
  1286.  
  1287. C Groupement de quatre UInt8 en un seul Int32
  1288. C (pour prendre moins de place !)
  1289. NBYTES=NEL
  1290. NBTROP=NEL-(NBYTES/4)*4
  1291. IF (NBTROP.GT.0) THEN
  1292. NEL1=NEL+4-NBTROP
  1293. SEGADJ,ITYEL
  1294. NBYTES=NEL1
  1295. ENDIF
  1296.  
  1297. WRITE(CNU1,FMT='(I15)') IPOS
  1298. IPOS=IPOS+ISIZNB+NBYTES
  1299.  
  1300. CALL LIMCHA(CNU1,ID1,IF1)
  1301. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1302. . '<DataArray type="UInt8" Name="types" '//
  1303. . 'format="appended" offset="'//CNU1(ID1:IF1)//'" />'
  1304.  
  1305. IOS=IXDRINT(IOBIN,NBYTES)
  1306.  
  1307. K20=0
  1308. DO K2=1,(NBYTES/4)
  1309. INT8=0
  1310. DO K1=1,4
  1311. INT8=INT8+(256**(4-K1))*ITYEL(K20+K1)
  1312. ENDDO
  1313. IOS=IXDRINT(IOBIN,INT8)
  1314. K20=K20+4
  1315. ENDDO
  1316.  
  1317. ENDIF
  1318.  
  1319. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1320. . '</Cells>'
  1321.  
  1322. C *************************************************************
  1323. C *************************************************************
  1324. C FIN D'ECRITURE DANS LE FICHIER
  1325.  
  1326.  
  1327. SEGSUP,IPOL2G,ICONN,IOFFS,ITYEL
  1328.  
  1329.  
  1330.  
  1331.  
  1332.  
  1333. C =============================================================
  1334. C G R A N D E U R S D E F I N I E S A U X N O E U D S
  1335. C =============================================================
  1336.  
  1337. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1338. . '<PointData>'
  1339.  
  1340. C (BOUCLE SUR LES CHAMPS PAR POINTS)
  1341. DO 200 ICHP=1,NBCHPO
  1342.  
  1343. MCHPO1=ICHPO(ICHP)
  1344. SEGACT,MCHPO1
  1345.  
  1346. C NSOUPO = Nombre de sous-champs
  1347. NSOUPO=MCHPO1.IPCHP(/1)
  1348. IF (NSOUPO.EQ.0) GOTO 200
  1349.  
  1350.  
  1351. C 1) CREATION DE LA LISTE DES COMPOSANTES DANS TCHCO
  1352. C On cree cette liste avant toute chose et non pas au fur
  1353. C et a mesure pour eviter de faire des SEGADJ sur le gros
  1354. C segment SCHPV
  1355. JGN=4
  1356. JGM=0
  1357. SEGINI,TCHCO
  1358. DO I1=1,NSOUPO
  1359. MSOUP1=MCHPO1.IPCHP(I1)
  1360. SEGACT,MSOUP1
  1361. NC=MSOUP1.NOCOMP(/2)
  1362. JGM1=JGM
  1363. DO 210 I2=1,NC
  1364. CHA4=MSOUP1.NOCOMP(I2)
  1365. DO I3=1,JGM1
  1366. IF (TCHCO.MOTS(I3).EQ.CHA4) GOTO 210
  1367. ENDDO
  1368. JGM=JGM+1
  1369. SEGADJ,TCHCO
  1370. TCHCO.MOTS(JGM)=CHA4
  1371. 210 CONTINUE
  1372. SEGDES,MSOUP1
  1373. ENDDO
  1374.  
  1375.  
  1376. C 2) CONCATENATION DE TOUS LES VPOCHA DANS XPOCHA
  1377. C - on ecrase la structure compliquee du CHPOINT dans un simple tableau (no.comp.;no.noeud)
  1378. C - on passe de la numerotation globale a la numerotation locale
  1379. NCO=JGM
  1380. SEGINI,SCHPV,ICOOK
  1381. DO 220 ISOU=1,NSOUPO
  1382. MSOUP1=MCHPO1.IPCHP(ISOU)
  1383. SEGACT,MSOUP1
  1384.  
  1385. MPOVA1=MSOUP1.IPOVAL
  1386. IF (MPOVA1.EQ.0) GOTO 219
  1387. SEGACT,MPOVA1
  1388.  
  1389. IPT2=MSOUP1.IGEOC
  1390. IF (IPT2.EQ.0) GOTO 218
  1391. SEGACT,IPT2
  1392.  
  1393. NN1=MPOVA1.VPOCHA(/1)
  1394. NC1=MPOVA1.VPOCHA(/2)
  1395.  
  1396. DO I1=1,NC1
  1397. C Recherche de la composante dans la liste TCHCO
  1398. CHA4=MSOUP1.NOCOMP(I1)
  1399. DO ICO=1,NCO
  1400. IF (TCHCO.MOTS(ICO).EQ.CHA4) GOTO 240
  1401. ENDDO
  1402.  
  1403. C MISE A JOUR DE SCHPV
  1404. C - si un noeud du support du SOUPO n'appartient pas au maillage courant, on passe au suivant
  1405. C - si un noeud du MAILLAGE courant n'est pas present dans le support du SOUPO, sa valeur reste a zero
  1406. 240 NTROUV=0
  1407. DO 250 I2=1,NN1
  1408. INO=IPOG2L(IPT2.NUM(1,I2))
  1409. IF (INO.EQ.0) GOTO 250
  1410. SCHPV.XPOCHA(ICO,INO)=SCHPV.XPOCHA(ICO,INO)
  1411. & +MPOVA1.VPOCHA(I2,I1)
  1412. NTROUV=1
  1413. 250 CONTINUE
  1414. IF (NTROUV.EQ.1) CALL AJOU(ICOOK,ICO)
  1415. ENDDO
  1416.  
  1417. SEGDES,IPT2
  1418. 218 SEGDES,MPOVA1
  1419. 219 SEGDES,MSOUP1
  1420. 220 CONTINUE
  1421.  
  1422. SEGDES,MCHPO1
  1423.  
  1424.  
  1425. C S'il n'y a rien a sortir, on passe au CHPOINT suivant
  1426. NCOK=ICOOK(/1)
  1427. IF (NCOK.EQ.0) GOTO 299
  1428. IF (NCOK.LT.NCO) CALL ORDO02(ICOOK(1),NCOK,.TRUE.)
  1429.  
  1430.  
  1431.  
  1432. C ECRITURE DANS LE FICHIER
  1433. C *********************************************************
  1434. C *********************************************************
  1435.  
  1436. CNOM=TCHPO(ICHP)
  1437.  
  1438. C ===================== FORMATE =====================
  1439. IF (IVTU.EQ.0) THEN
  1440.  
  1441. WRITE(CNU1,FMT='(I15)') NCOK
  1442. CALL LIMCHA(CNU1,ID1,IF1)
  1443.  
  1444. WRITE(UNIT=IOXML,
  1445. . FMT='(16X,A)',
  1446. . IOSTAT=IOS,
  1447. . ADVANCE="NO")
  1448. . '<DataArray type="'//FLDAT//'" '//
  1449. . 'Name="'//CNOM(1:LONG(CNOM))//'" '//
  1450. . 'NumberOfComponents="'//CNU1(ID1:IF1)//'" '
  1451.  
  1452. DO K=1,NCOK
  1453. CHA4=TCHCO.MOTS(ICOOK(K))
  1454. CALL LIMCHA(CHA4,ID4,IF4)
  1455. WRITE(UNIT=IOXML,
  1456. . FMT='(A,I0,A,A,A)',
  1457. . IOSTAT=IOS,
  1458. . ADVANCE="NO")
  1459. . 'ComponentName',K-1,'="',CHA4(ID4:IF4),'" '
  1460. ENDDO
  1461.  
  1462. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1463. . 'format="ascii">'
  1464.  
  1465. WRITE(MYFMT,FMT='("(20X,",I2,A8,")")') NCOK,FMDAT
  1466. WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS)
  1467. . ((SCHPV.XPOCHA(ICOOK(K),J),K=1,NCOK),J=1,NNO)
  1468.  
  1469. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1470. . '</DataArray>'
  1471.  
  1472.  
  1473. C ===================== BINAIRE =====================
  1474. ELSE
  1475. NBYTES=(NCOK*NNO)*ISIZDA
  1476.  
  1477. WRITE(CNU1,FMT='(I15)') IPOS
  1478. IPOS=IPOS+ISIZNB+NBYTES
  1479.  
  1480. WRITE(CNU2,FMT='(I15)') NCOK
  1481. CALL LIMCHA(CNU1,ID1,IF1)
  1482. CALL LIMCHA(CNU2,ID2,IF2)
  1483.  
  1484. WRITE(UNIT=IOXML,
  1485. . FMT='(16X,A)',
  1486. . IOSTAT=IOS,
  1487. . ADVANCE="NO")
  1488. . '<DataArray type="'//FLDAT//'" '//
  1489. . 'Name="'//CNOM(1:LONG(CNOM))//'" '//
  1490. . 'NumberOfComponents="'//CNU2(ID2:IF2)//'" '
  1491.  
  1492. DO K=1,NCOK
  1493. CHA4=TCHCO.MOTS(ICOOK(K))
  1494. CALL LIMCHA(CHA4,ID4,IF4)
  1495. WRITE(UNIT=IOXML,
  1496. . FMT='(A,I0,A,A,A)',
  1497. . IOSTAT=IOS,
  1498. . ADVANCE="NO")
  1499. . 'ComponentName',K-1,'="',CHA4(ID4:IF4),'" '
  1500. ENDDO
  1501.  
  1502. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1503. . 'format="appended" offset="'//CNU1(ID1:IF1)//'" />'
  1504.  
  1505. IOS=IXDRINT(IOBIN,NBYTES)
  1506.  
  1507. IF (ZDOUB) THEN
  1508. DO J=1,NNO
  1509. DO K=1,NCOK
  1510. XRE8=SCHPV.XPOCHA(ICOOK(K),J)
  1511. IOS=IXDRDOUBLE(IOBIN,XRE8)
  1512. ENDDO
  1513. ENDDO
  1514. ELSE
  1515. DO J=1,NNO
  1516. DO K=1,NCOK
  1517. XRE4=REAL(SCHPV.XPOCHA(ICOOK(K),J),4)
  1518. IOS=IXDRREAL(IOBIN,XRE4)
  1519. ENDDO
  1520. ENDDO
  1521. ENDIF
  1522. ENDIF
  1523.  
  1524. C *********************************************************
  1525. C *********************************************************
  1526. C FIN D'ECRITURE DANS LE FICHIER
  1527.  
  1528.  
  1529. 299 SEGSUP,SCHPV,TCHCO,ICOOK
  1530.  
  1531.  
  1532. 200 CONTINUE
  1533. C (FIN DE LA BOUCLE SUR LES CHAMPS PAR POINTS)
  1534.  
  1535. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1536. . '</PointData>'
  1537.  
  1538.  
  1539. SEGSUP,IPOG2L
  1540.  
  1541.  
  1542.  
  1543.  
  1544.  
  1545. C =============================================================
  1546. C G R A N D E U R S D E F I N I E S P A R E L E M E N T
  1547. C =============================================================
  1548.  
  1549. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1550. . '<CellData>'
  1551.  
  1552. C (BOUCLE SUR LES CHAMPS PAR ELEMENTS)
  1553. DO 300 ICHE=1,NBCHML
  1554.  
  1555. MCHEL1=ICHML(ICHE)
  1556. SEGACT,MCHEL1
  1557.  
  1558. C NSOCHA = Nombre de sous-champs
  1559. NSOCHA=MCHEL1.ICHAML(/1)
  1560. IF (NSOCHA.EQ.0) GOTO 300
  1561.  
  1562.  
  1563. C 1) CREATION DE LA LISTE DES COMPOSANTES DANS TCHCO
  1564. C On cree cette liste avant toute chose et non pas au fur
  1565. C et a mesure pour eviter de faire des SEGADJ sur le gros
  1566. C segment SCHMV
  1567. C + VERIFICATIONS SUR LE TYPE DE MCHAML
  1568. JGN=8
  1569. JGM=0
  1570. SEGINI,TCHCO
  1571. DO I1=1,NSOCHA
  1572. MCHAM1=MCHEL1.ICHAML(I1)
  1573. SEGACT,MCHAM1
  1574.  
  1575. NC1=MCHAM1.IELVAL(/1)
  1576. JGM1=JGM
  1577. DO 310 I2=1,NC1
  1578.  
  1579. C VERIFICATION 1 : composante de type scalaire ?
  1580. IF (MCHAM1.TYPCHE(I2).NE.'REAL*8') THEN
  1581. C ERREUR CRITIQUE 679 (Le type de la composante %m1:8 du MCHAML est incorrect)
  1582. MOTERR(1:8)=MCHAM1.NOMCHE(I2)
  1583. CALL ERREUR(679)
  1584. WRITE(IOIMP,*) '(le champ par elements "',
  1585. . TCHML(ICHE),'" contient des ',
  1586. . 'composantes non scalaires'
  1587. GOTO 999
  1588. ENDIF
  1589.  
  1590. C VERIFICATION 2 : une seule valeur par cellule ?
  1591. MELVA1=MCHAM1.IELVAL(I2)
  1592. SEGACT,MELVA1
  1593. IF (MELVA1.VELCHE(/1).NE.1) THEN
  1594. C ERREUR CRITIQUE 707 (Le MCHAML doit contenir une valeur (de chaque composante) par element)
  1595. CALL ERREUR(707)
  1596. WRITE(IOIMP,*) '(le champ par elements "',
  1597. . TCHML(ICHE),'" n''est pas de',
  1598. . ' type "GRAVITE")'
  1599. GOTO 999
  1600. ENDIF
  1601. SEGDES,MELVA1
  1602.  
  1603. C CREATION DE LA LISTE TCHCO
  1604. CHA8=MCHAM1.NOMCHE(I2)
  1605. DO I3=1,JGM1
  1606. IF (TCHCO.MOTS(I3).EQ.CHA8) GOTO 310
  1607. ENDDO
  1608. JGM=JGM+1
  1609. SEGADJ,TCHCO
  1610. TCHCO.MOTS(JGM)=CHA8
  1611. 310 CONTINUE
  1612.  
  1613. SEGDES,MCHAM1
  1614. ENDDO
  1615.  
  1616.  
  1617.  
  1618. C 2) CONCATENATION DE TOUS LES VELCHE DANS XELCHE
  1619. C - on ecrase la structure compliquee du MCHAML dans un simple tableau (no.comp.;no.cell.)
  1620. C - on passe de la numerotation globale a la numerotation locale
  1621. NCO=JGM
  1622. SEGINI,SCHMV,ICOOK
  1623. DO 320 I1=1,NSOCHA
  1624. MCHAM1=MCHEL1.ICHAML(I1)
  1625. SEGACT,MCHAM1
  1626.  
  1627. C IPT2 = SUPPORT DU SOUS-CHAMP DU MCHAML
  1628. IPT2=MCHEL1.IMACHE(I1)
  1629. SEGACT,IPT2
  1630. ITYP2=IPT2.ITYPEL
  1631. ITY2=ITYVTK(ITYP2)
  1632. IF (ITY2.EQ.0) THEN
  1633. C ERREUR CRITIQUE 21 (Donnees incompatibles)
  1634. CALL ERREUR(21)
  1635. WRITE(IOIMP,*) 'Le champ "',TCHML(ICHE),
  1636. . '" s''appuye sur des elements ',
  1637. . NOMS(ITYP),' incompatibles avec VTK'
  1638. GOTO 999
  1639. ENDIF
  1640. NEL2=IPT2.NUM(/2)
  1641.  
  1642.  
  1643. C IPT3 = SOUS-MELEME DU MAILLAGE COURANT CONSTITUE DU
  1644. C MEME TYPE D'ELEMENTS QUE IPT2
  1645. I3=ITYPII(ITYP2)
  1646. IF (I3.EQ.0) GOTO 319
  1647. IPT3=IPT1
  1648. IF (NBSOU.GT.0) THEN
  1649. IPT3=IPT1.LISOUS(I3)
  1650. SEGACT,IPT3
  1651. ENDIF
  1652. NNN3=IPT3.NUM(/1)
  1653. NEL3=IPT3.NUM(/2)
  1654.  
  1655.  
  1656. C On cherche pour chaque element de IPT2 un element de
  1657. C IPT3 qui possede les memes noeuds, dans le meme ordre
  1658. SEGINI,IELL2G
  1659. DO 330 IEL2=1,NEL2
  1660. DO 331 IEL3=1,NEL3
  1661. DO INO=1,NNN3
  1662. INUM2=IPT2.NUM(INO,IEL2)
  1663. INUM3=IPT3.NUM(INO,IEL3)
  1664. IF (INUM2.NE.INUM3) GOTO 331
  1665. ENDDO
  1666.  
  1667. C ON A TROUVE UN ELEMENT COMMUN A IPT2 ET IPT3
  1668. IELL2G(IEL2)=INECUM(I3)+IEL3
  1669. GOTO 330
  1670. 331 CONTINUE
  1671. 330 CONTINUE
  1672.  
  1673.  
  1674. C Remplissage de SCHMV pour chaque composante du SOCHA
  1675. DO 340 J1=1,NCO
  1676. MELVA1=MCHAM1.IELVAL(J1)
  1677. IF (MELVA1.EQ.0) GOTO 340
  1678. SEGACT,MELVA1
  1679. NBVAL=MELVA1.VELCHE(/2)
  1680.  
  1681. C Recherche de la composante dans la liste TCHCO
  1682. CHA8=MCHAM1.NOMCHE(J1)
  1683. DO ICO=1,NCO
  1684. IF (TCHCO.MOTS(ICO).EQ.CHA8) GOTO 350
  1685. ENDDO
  1686.  
  1687. C MISE A JOUR DE SCHMV
  1688. C - si une cellule du support du SOCHA n'appartient pas au maillage courant, on passe a la suivante
  1689. C - si une cellule du MAILLAGE courant n'est pas presente dans le support du SOCHA, sa valeur reste a zero
  1690. 350 NTROUV=0
  1691. DO 360 J2=1,NEL2
  1692. IEL=IELL2G(J2)
  1693. IF (IEL.EQ.0) GOTO 360
  1694. IF (NBVAL.EQ.1) THEN
  1695. C ATTENTION, le MELVA1 est uniforme !
  1696. SCHMV.XELCHE(ICO,IEL)=MELVA1.VELCHE(1,1)
  1697. ELSE
  1698. SCHMV.XELCHE(ICO,IEL)=MELVA1.VELCHE(1,J2)
  1699. ENDIF
  1700. NTROUV=1
  1701. 360 CONTINUE
  1702. IF (NTROUV.EQ.1) CALL AJOU(ICOOK,ICO)
  1703.  
  1704. SEGDES,MELVA1
  1705. 340 CONTINUE
  1706.  
  1707.  
  1708. SEGSUP,IELL2G
  1709.  
  1710. C /!\ IPT2 et IPT3 peuvent etre egaux a IPT1, or IPT1 doit rester actif !!
  1711. IF (NBSOU.GT.0) SEGDES,IPT3
  1712. 319 IF (IPT2.NE.IPT1) SEGDES,IPT2
  1713.  
  1714. SEGDES,MCHAM1
  1715.  
  1716. 320 CONTINUE
  1717.  
  1718. SEGDES,MCHEL1
  1719.  
  1720.  
  1721. C S'il n'y a rien a sortir, on passe au MCHAML suivant
  1722. NCOK=ICOOK(/1)
  1723. IF (NCOK.EQ.0) GOTO 399
  1724. IF (NCOK.LT.NCO) CALL ORDO02(ICOOK(1),NCOK,.TRUE.)
  1725.  
  1726.  
  1727.  
  1728.  
  1729. C ECRITURE DANS LE FICHIER
  1730. C *********************************************************
  1731. C *********************************************************
  1732.  
  1733. CNOM=TCHML(ICHE)
  1734.  
  1735. C ===================== FORMATE =====================
  1736. IF (IVTU.EQ.0) THEN
  1737.  
  1738. WRITE(CNU1,FMT='(I15)') NCOK
  1739. CALL LIMCHA(CNU1,ID1,IF1)
  1740. C
  1741. WRITE(UNIT=IOXML,
  1742. . FMT='(16X,A)',
  1743. . IOSTAT=IOS,
  1744. . ADVANCE="NO")
  1745. . '<DataArray type="'//FLDAT//'" '//
  1746. . 'Name="'//CNOM(1:LONG(CNOM))//'" '//
  1747. . 'NumberOfComponents="'//CNU1(ID1:IF1)//'" '
  1748.  
  1749. DO K=1,NCOK
  1750. CHA8=TCHCO.MOTS(ICOOK(K))
  1751. CALL LIMCHA(CHA8,ID4,IF4)
  1752. WRITE(UNIT=IOXML,
  1753. . FMT='(A,I0,A,A,A)',
  1754. . IOSTAT=IOS,
  1755. . ADVANCE="NO")
  1756. . 'ComponentName',K-1,'="',CHA8(ID4:IF4),'" '
  1757. ENDDO
  1758.  
  1759. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1760. . 'format="ascii">'
  1761.  
  1762. WRITE(MYFMT,FMT='("(20X,",I2,A8,")")') NCOK,FMDAT
  1763. WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS)
  1764. . ((SCHMV.XELCHE(ICOOK(K),J),K=1,NCOK),J=1,NEL)
  1765.  
  1766. WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS)
  1767. . '</DataArray>'
  1768.  
  1769.  
  1770. C ===================== BINAIRE =====================
  1771. ELSE
  1772. NBYTES=(NCOK*NEL)*ISIZDA
  1773.  
  1774. WRITE(CNU1,FMT='(I15)') IPOS
  1775. IPOS=IPOS+ISIZNB+NBYTES
  1776.  
  1777. WRITE(CNU2,FMT='(I15)') NCOK
  1778. CALL LIMCHA(CNU1,ID1,IF1)
  1779. CALL LIMCHA(CNU2,ID2,IF2)
  1780.  
  1781. WRITE(UNIT=IOXML,
  1782. . FMT='(16X,A)',
  1783. . IOSTAT=IOS,
  1784. . ADVANCE="NO")
  1785. . '<DataArray type="'//FLDAT//'" '//
  1786. . 'Name="'//CNOM(1:LONG(CNOM))//'" '//
  1787. . 'NumberOfComponents="'//CNU2(ID2:IF2)//'" '
  1788.  
  1789. DO K=1,NCOK
  1790. CHA8=TCHCO.MOTS(ICOOK(K))
  1791. CALL LIMCHA(CHA8,ID4,IF4)
  1792. WRITE(UNIT=IOXML,
  1793. . FMT='(A,I0,A,A,A)',
  1794. . IOSTAT=IOS,
  1795. . ADVANCE="NO")
  1796. . 'ComponentName',K-1,'="',CHA8(ID4:IF4),'" '
  1797. ENDDO
  1798.  
  1799. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1800. . 'format="appended" offset="'//CNU1(ID1:IF1)//'" />'
  1801.  
  1802. IOS=IXDRINT(IOBIN,NBYTES)
  1803.  
  1804. IF (ZDOUB) THEN
  1805. DO J=1,NEL
  1806. DO K=1,NCOK
  1807. XRE8=SCHMV.XELCHE(ICOOK(K),J)
  1808. IOS=IXDRDOUBLE(IOBIN,XRE8)
  1809. ENDDO
  1810. ENDDO
  1811. ELSE
  1812. DO J=1,NEL
  1813. DO K=1,NCOK
  1814. XRE4=REAL(SCHMV.XELCHE(ICOOK(K),J),4)
  1815. IOS=IXDRREAL(IOBIN,XRE4)
  1816. ENDDO
  1817. ENDDO
  1818. ENDIF
  1819. ENDIF
  1820.  
  1821. C *********************************************************
  1822. C *********************************************************
  1823. C FIN D'ECRITURE DANS LE FICHIER
  1824.  
  1825.  
  1826. 399 SEGSUP,SCHMV,TCHCO,ICOOK
  1827.  
  1828.  
  1829. 300 CONTINUE
  1830. C (FIN DE LA BOUCLE SUR LES CHAMPS PAR ELEMENTS)
  1831.  
  1832. WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS)
  1833. . '</CellData>'
  1834.  
  1835.  
  1836.  
  1837. SEGDES,IPT1
  1838. IF (NBCHML.GT.0) SEGSUP,ITYPII,INECUM
  1839.  
  1840.  
  1841.  
  1842.  
  1843. C =============================================================
  1844. C F E R M E T U R E D U F I C H I E R . V T U
  1845. C =============================================================
  1846.  
  1847. WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS)
  1848. . '</Piece>'
  1849.  
  1850. WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS)
  1851. . '</UnstructuredGrid>'
  1852.  
  1853.  
  1854. C CAS DES FICHIERS BINAIRES (OPTIONS 'BINA' OU 'ZIP')
  1855. C On doit recopier le contenu du fichier .bin dans la balise
  1856. C <AppendedData> du fichier .vtu
  1857. IF (IVTU.GT.0) THEN
  1858.  
  1859. WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS)
  1860. . '<AppendedData encoding="raw">'
  1861.  
  1862. C Changement de mode d'ecriture ASCII->BINAIRE pour le .vtu
  1863. CLOSE(UNIT=IOXML)
  1864. IOBIN2=INITXDR(NOM3,'a',.FALSE.)
  1865.  
  1866. C Relecture et copie du fichier binaire
  1867. C (par paquets de 4 octets, "brique de base" de XDR)
  1868. IOS=IXDRCLOSE(IOBIN)
  1869. IOBIN=INITXDR(NOM3(1:LONG(NOM3))//'.bin','r',.FALSE.)
  1870. DO I=1,(1+(IPOS/4))
  1871. IOS=IXDRINT(IOBIN ,INT8)
  1872. IOS=IXDRINT(IOBIN2,INT8)
  1873. ENDDO
  1874.  
  1875. C Suppression du fichier binaire temporaire
  1876. IOS=IXDRCLOSE(IOBIN)
  1877. OPEN(UNIT = IOBIN,
  1878. . FILE = NOM3(1:LONG(NOM3))//'.bin')
  1879. CLOSE(UNIT=IOBIN,STATUS='DELETE')
  1880.  
  1881. C Insertion des marqueurs EOR et EOF pour que le contenu de
  1882. C la section binaire ne soit pas ecrase lors de la fermeture
  1883. C de la balise </AppendedData> (effectuee ci-apres)
  1884. IOS=IXDRINT(IOBIN2,IXDR2)
  1885. IOS=IXDRINT(IOBIN2,IXDR2)
  1886.  
  1887. C Changement de mode d'ecriture BINAIRE->ASCII pour le .vtu
  1888. IOS=IXDRCLOSE(IOBIN2)
  1889. OPEN(UNIT = IOXML ,
  1890. . FILE = NOM3 ,
  1891. . STATUS = 'UNKNOWN' ,
  1892. . FORM = 'FORMATTED' ,
  1893. . ACCESS = 'SEQUENTIAL' ,
  1894. . IOSTAT = IOS )
  1895. CALL FINFIC(IOXML)
  1896.  
  1897. WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS)
  1898. . '</AppendedData>'
  1899.  
  1900. ENDIF
  1901.  
  1902. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1903. . '</VTKFile>'
  1904.  
  1905.  
  1906. CLOSE(UNIT=IOXML)
  1907.  
  1908.  
  1909. 100 CONTINUE
  1910. C (FIN DE LA BOUCLE SUR LES MAILLAGES)
  1911.  
  1912.  
  1913.  
  1914.  
  1915.  
  1916. C***********************************************************************
  1917. C***********************************************************************
  1918. C***********************************************************************
  1919. C***********************************************************************
  1920.  
  1921.  
  1922.  
  1923.  
  1924. C +---------------------------------------------------------------+
  1925. C | |
  1926. C | E C R I T U R E D U F I C H I E R . P V D |
  1927. C | |
  1928. C +---------------------------------------------------------------+
  1929.  
  1930. C Nom du fichier .pvd
  1931. NOM3=NOM1(1:LONG(NOM1))//NOMFIC(1:LONG(NOMFIC))//'.pvd'
  1932.  
  1933.  
  1934. C 1) Option 'NPVD'
  1935. C => fin de la subroutine
  1936. IF (IPVD.EQ.3) GOTO 999
  1937.  
  1938.  
  1939. C 2) Option 'AUTO' ou 'SUIT' quand le .pvd existe et est compatible
  1940. C => on complete le .pvd
  1941.  
  1942. IF (IPVD.LT.2.AND.ZEXIS) THEN
  1943.  
  1944. C On se place a la fin du fichier existant puis...
  1945. OPEN(UNIT = IOXML ,
  1946. . FILE = NOM3 ,
  1947. . STATUS = 'OLD' ,
  1948. . FORM = 'FORMATTED' ,
  1949. . ACCESS = 'SEQUENTIAL' ,
  1950. . IOSTAT = IOS )
  1951. CALL FINFIC(IOXML)
  1952.  
  1953. C ...on recule de NLFOOTER enregistrements pour ecraser les
  1954. C balises de fermeture
  1955. DO I1=1,NLFOOTER
  1956. BACKSPACE(IOXML)
  1957. ENDDO
  1958.  
  1959.  
  1960. C 3) Option 'NOUV', ou pas de fichier existant et compatible
  1961. C => on cree le .pvd (ou on l'ecrase)
  1962. ELSE
  1963. OPEN(UNIT = IOXML ,
  1964. . FILE = NOM3 ,
  1965. . STATUS = 'UNKNOWN' ,
  1966. . FORM = 'FORMATTED' ,
  1967. . ACCESS = 'SEQUENTIAL' ,
  1968. . IOSTAT = IOS )
  1969. REWIND(IOXML)
  1970.  
  1971. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1972. . '<?xml version="1.0"?>'
  1973.  
  1974. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1975. . CHEAD(1:LHEAD)
  1976.  
  1977. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS)
  1978. . '<VTKFile type="Collection" version="0.1">'
  1979.  
  1980. WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS)
  1981. . '<Collection>'
  1982. ENDIF
  1983.  
  1984.  
  1985. DO IMAI=1,NBMAIL
  1986.  
  1987. C Indice de la partition mis sous forme d'une chaine de 4 caracteres
  1988. WRITE(CHA4,FMT='(I4.4)') IPART(IMAI)
  1989.  
  1990. C Nom de chaque fichier .vtu cree par cette execution de la subroutine
  1991. NOM3=NOM2
  1992. IF ((.NOT.ZTEMP.AND.IPVD.LT.3).OR.ZPART) THEN
  1993. NOM3=NOM3(1:LONG(NOM3))//'.'//CHA4
  1994. ENDIF
  1995. NOM3=NOM3(1:LONG(NOM3))//'.vtu'
  1996.  
  1997. C ECRITURE DE LA LIGNE CORRESPONDANTE DANS LA COLLECTION
  1998. C - champ 'timestep' : seulement avec l'option 'TEMP'
  1999. C - champ 'part' : en l'absence de 'TEMP', ou si plusieurs maillages etaient fournis
  2000. C - champ 'name' : idem que 'part'
  2001. C - champ 'file' : toujours !!
  2002. IF (ZTEMP) THEN
  2003.  
  2004. WRITE(MYFMT,FMT='("(",A8,")")') FMDAT
  2005. WRITE(CNU1,FMT=MYFMT,IOSTAT=IOS) XTPS
  2006. CALL LIMCHA(CNU1,ID1,IF1)
  2007.  
  2008. IF (ZPART) THEN
  2009. CNOM=TMAIL(IMAI)
  2010. WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS)
  2011. . '<DataSet timestep="'//CNU1(ID1:IF1)//'" '//
  2012. . 'part="'//CHA4//'" '//
  2013. . 'name="'//CNOM(1:LONG(CNOM))//'" '//
  2014. . 'file="'//NOM3(1:LONG(NOM3))//'"/>'
  2015. ELSE
  2016. WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS)
  2017. . '<DataSet timestep="'//CNU1(ID1:IF1)//'" '//
  2018. . 'file="'//NOM3(1:LONG(NOM3))//'"/>'
  2019. ENDIF
  2020. ELSE
  2021. CNOM=TMAIL(IMAI)
  2022. WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS)
  2023. . '<DataSet part="'//CHA4//
  2024. . '" name="'//CNOM(1:LONG(CNOM))//
  2025. . '" file="'//NOM3(1:LONG(NOM3))//'"/>'
  2026. ENDIF
  2027. ENDDO
  2028.  
  2029.  
  2030. WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) '</Collection>'
  2031. WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) '</VTKFile>'
  2032.  
  2033. CLOSE(UNIT=IOXML)
  2034.  
  2035.  
  2036.  
  2037.  
  2038. C***********************************************************************
  2039. C***********************************************************************
  2040. C***********************************************************************
  2041. C***********************************************************************
  2042.  
  2043.  
  2044.  
  2045.  
  2046. C +---------------------------------------------------------------+
  2047. C | |
  2048. C | F I N D E L A S U B R O U T I N E |
  2049. C | |
  2050. C +---------------------------------------------------------------+
  2051.  
  2052.  
  2053. 999 CONTINUE
  2054. SEGDES,SMAIL,SCHPO,SCHML
  2055.  
  2056.  
  2057. RETURN
  2058.  
  2059. END
  2060.  
  2061.  
  2062.  
  2063.  
  2064.  
  2065.  
  2066.  
  2067.  
  2068.  
  2069.  
  2070.  

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