C SORVTK SOURCE JC220346 13/11/19 21:15:00 7867 ************************************************************************ * NOM : sorvtk.eso * DESCRIPTION : Sortie d'objets de type MAILLAGE, CHPOINT et/ou MCHAML * au format VTK * REFERENCE : VTK File Formats for VTK Version 4.2, extrait de * The VTK User's Guide, Kitware * (www.vtk.org/VTK/img/file-formats.pdf) ************************************************************************ * HISTORIQUE : 18/06/2012 : JCARDO : création de la subroutine * HISTORIQUE : 20/06/2012 : JCARDO : bug impression ITYEL en BINA * HISTORIQUE : * HISTORIQUE : ************************************************************************ * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES * en cas de modification de ce sous-programme afin de faciliter * la maintenance ! ************************************************************************ * APPELÉ PAR : opérateur SORTir (prsort.eso) ************************************************************************ * ENTRÉES :: aucune * SORTIES :: aucune (sur fichiers uniquement) ************************************************************************ * SYNTAXE (GIBIANE) : * * SORT 'VTK' OBJ1 (MOT1) ... (OBJn) (MOTn) * (|'FORM'|) (|'AUTO'|) ('TEMP' FLOT1) ('DOUBLE_PRECISION') * |'BINA'| |'NOUV'| * |'ZIP' | |'SUIT'| * |'NPVD'| * * avec OBJi = [ MAILi | CHPOi | CHMLi | TABi ] * ************************************************************************ SUBROUTINE SORVTK IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCGEOME -INC CCOPTIO -INC SMCOORD -INC SMELEME -INC SMCHPOI -INC SMCHAML -INC SMLMOTS -INC SMTABLE -INC CCNOYAU -INC CCASSIS -INC CCFXDR EXTERNAL LONG * CARACTERE DOUBLE-QUOTE (") * -------------------------- * Bug dans le traducteur ESOPE pour qui ' et " ont le même rôle * => lors de la traduction d'une chaine 'xxxx"yyyy"zzzz', la chaine * yyyy est mise en majuscule * => Paraview n'arrive pas à relire les .vtu car il ne reconnait * pas la valeur de certains attributs ("BigEndian", "Appended", * "UnstructuredGrid"...) CHARACTER*1 DQ c PARAMETER(DQ=ACHAR(34)) * OCTETS PRE-DEFINIS A ECRIRE DANS LA SECTION * ---------------------------------------------------------- * IXDR1=représentation décimale BigEndian de la chaîne ' _' * IXDR2=représentation décimale BigEndian du marqueur End-Of-Record INTEGER*4 IXDR1,IXDR2 DATA IXDR1/538976351/ DATA IXDR2/10/ * SEGMENTS DE TRAVAIL TEMPORAIRES * ------------------------------- * SMAIL = données sur les maillages lus (pointeur et nom) * SCHPO = données sur les champs par points lus (pointeur et nom) * SCHML = données sur les champs par éléments lus (pointeur et nom) * ICONN,IOFFS,ITYEL = données sur les cellules du maillage courant * IPOL2G|= Tables de correspondance entre la numérotation (globale) * IPOG2L| des noeuds dans XCOOR et la numérotation (locale) des * noeuds du maillage dans le fichier .vtu * IELL2G = Table de correspondance entre la numérotation (globale) * des cellules du MAILLAGE courant et la numérotation * (locale) des cellules du MCHAML courant * ITYPII = donne le sous-maillage formé d'un type donné d'élément * INECUM = donne le nombre cumulé d'éléments des sous-maillages * TCHCO = liste des composantes du CHPOINT ou du MCHAML courant * ICOOK = liste des composantes à sortir (au moins 1 valeur) * SCHPV = tableau compacté des valeurs du CHPOINT courant * SCHMV = tableau compacté des valeurs du MCHAML courant SEGMENT SMAIL INTEGER IMAIL(NBMAIL) CHARACTER*4 TMAIL(NBMAIL) ENDSEGMENT SEGMENT SCHPO INTEGER ICHPO(NBCHPO) CHARACTER*8 TCHPO(NBCHPO) ENDSEGMENT SEGMENT SCHML INTEGER ICHML(NBCHML) CHARACTER*8 TCHML(NBCHML) ENDSEGMENT SEGMENT IPOL2G(NNO) SEGMENT IPOG2L(NPMAX) SEGMENT IELL2G(NEL2) SEGMENT ICONN(NBCON) SEGMENT IOFFS(NEL) SEGMENT ITYEL(NEL1) SEGMENT ITYPII(NOMBR) SEGMENT INECUM(NBSOU1) POINTEUR TCHCO.MLMOTS SEGMENT ICOOK(0) SEGMENT SCHPV REAL*8 XPOCHA(NCO,NNO) ENDSEGMENT SEGMENT SCHMV REAL*8 XELCHE(NCO,NEL) ENDSEGMENT * MOTS-CLÉS DE L'OPÉRATEUR * ------------------------ PARAMETER(LMCLE=9) CHARACTER*4 MCLE(LMCLE) DATA MCLE/'AUTO','SUIT','NOUV','NPVD', & 'FORM','BINA','ZIP', & 'TEMP', & 'DOUB'/ * VARIABLES BOOLÉENNES * -------------------- * ZEXIS = vrai si le fichier .pvd existe déjà (et est compatible) * ZTEMP = vrai si le pas de temps a été indiqué (mot-clé 'TEMP') * ZPART = vrai si plusieurs maillages ont été transmis * ZOPT1,ZOPT2 = utilisés pour s'assurer que plusieurs mots-clés * d'une même option n'ont pas été lus * ZOPEN = vrai si OPTI 'SORT' a bien été appelé au préalable * ZDOUB = vrai si on écrit les données en double précision LOGICAL ZEXIS,ZTEMP,ZPART,ZOPT1,ZOPT2,ZOPEN,ZDOUB * TABLEAUX DE CORRESPONDANCE entre les éléments géométriques de * CAST3M et ceux de VTK (www.vtk.org/VTK/img/file-formats.pdf) * -------------------- INTEGER*2 ITYVTK(48) DATA ITYVTK * POI1 SEG2 SEG3 TRI3 TRI4 TRI6 TRI7 QUA4 QUA5 . / 1 , 3 , 21 , 5 , 0 , 22 , 0 , 9 , 0 , * QUA8 QUA9 RAC2 RAC3 CUB8 CU20 PRI6 PR15 LIA3 . 23 , 0 , 0 , 0 , 12 , 25 , 13 , 0 , 0 , * LIA4 LIA6 LIA8 MULT TET4 TE10 PYR5 PY13 ATTA . 0 , 0 , 0 , 0 , 10 , 24 , 14 , 0 , 0 , * SUPE RAP3 LIP6 LIP8 POLY CU27 PR21 TE15 PY19 . 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , * SEG4 QU16 TR12 PR18 SEG6 TR21 QU36 C216 P126 . 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , * TE56 PY91 SURE . 0 , 0 , 0 / * Correspondance des numerotations pour les elements quadratiques INTEGER*2 INUVTK(20, 5) INTEGER*2 NUSEG3(3), NUTRI6(6), NUQUA8(8), NUTE10(10), NUCU20(20) DATA NUSEG3 / 1, 3, 2 / DATA NUTRI6 / 1, 3, 5, 2, 4, 6 / DATA NUQUA8 / 1, 3, 5, 7, 2, 4, 6, 8 / DATA NUTE10 / 1, 3, 5, 10, 2, 4, 6, 7, 8, 9 / DATA NUCU20 / 1, 3, 5, 7, 13, 15, 17, 19, 2, 4, 6, 8, 14, 16, 18, . 20, 9, 10, 11, 12 / EQUIVALENCE (INUVTK(1,1),NUSEG3(1)), . (INUVTK(1,2),NUTRI6(1)), . (INUVTK(1,3),NUQUA8(1)), . (INUVTK(1,4),NUTE10(1)), . (INUVTK(1,5),NUCU20(1)) * AUTRES DÉCLARATIONS * ------------------- * Chaînes de caractères génériques CHARACTER*4 CHA4 CHARACTER*8 CHA8 CHARACTER*9 CHA9 * Chaînes de caractères pour la conversion de nombres CHARACTER*15 CNU1,CNU2 * Variables pour la manipulation des noms de fichiers CHARACTER*72 NOM1,NOM2,NOM3 * Variable pour les formats I/O dynamiques CHARACTER*30 MYFMT * Buffer utilisé lors de la lecture préliminaire du fichier .pvd CHARACTER*200 CBUF * Ligne de commentaire écrite en-tête de tous les fichiers CHARACTER*120 CHEAD * ***************************************************************** * CONTRÔLE DE LA TAILLE ET DE LA PRÉCISION DES DONNÉES NUMÉRIQUES * ÉCRITES SUR LES UNITÉS DE SORTIE IOXML ET IOBIN * ***************************************************************** * * /!\ CHOIX NON MODIFIABLES PAR 'DOUBLE_PRECISION' : * * - En BINAire : * => les connectivités et offsets des cellules sont écrits sur * 4 octets, ce qui "limite" le nombre de noeuds à 2 milliards * => les types des cellules sont codés sur 1 octet (puis groupés * par 4 pour pouvoir être écrits par XDR) * => Le standard VTK impose que la variable NBYTES ci-dessous * soit écrite sur 4 octets (soit ISIZNB=4) * * - En FORMaté : * => les CHPOINT et MCHAML sont écrits sur N colonnes, où N est * le nombre de composantes : il y aura une erreur si N est * un multiple de 100 car N est écrit au format I2. * * ------------------------------ * NBYTES=Nombre d'octets écrits jusqu'alors dans la section AppendedData (hors caractère '_' initial) * ISIZNB=Taille (en octets) sur laquelle écrire la variable NBYTES INTEGER NBYTES PARAMETER(ISIZNB=4) * Formats numériques prédéfinis pour l'écriture de réels CHARACTER*8 FMR4,FMR8 PARAMETER(FMR4='E14.6E2 ') PARAMETER(FMR8='E24.15E3') * Variables à modifier selon la valeur de ZDOUB * - FMDAT=[FMR4|FMR8] * - FLDAT=['Float32'|'Float64'] * - ISIZDA=[4|8] CHARACTER*8 FMDAT CHARACTER*7 FLDAT INTEGER ISIZDA * Variables génériques de précision donnée INTEGER*4 INT4 REAL*4 XRE4,YRE4,ZRE4 REAL*8 XRE8,YRE8,ZRE8 * (FIN DES DECLARATIONS) * ***************************************************************** * ***************************************************************** * Caractère DOUBLE-QUOTE (certains compilateurs ne supportent pas * qu'il soit défini en PARAMETER...) * => obligatoire du fait d'un preprocesseur ESOPE trop gourmand qui * convertit en majuscules tout ce qui est entre guillemets (") DQ=ACHAR(34) * Numéro de la sortie logique vers le fichier .vtu * (le numéro de l'éventuel .bin sera renvoyé par INITXDR) IOXML=IOPER * Nombre max. de noeuds (pour dimensionner les tableaux) IDIM1=IDIM+1 NPMAX=XCOOR(/1)/IDIM1 * Nom de base des fichiers à sortir INQUIRE(UNIT=IOPER,OPENED=ZOPEN) IF (.NOT.ZOPEN) THEN CALL ERREUR(-212) WRITE(IOIMP,*) '(via OPTI "SORT")' MOTERR(1:8)='VTK ' CALL ERREUR(705) RETURN ENDIF INQUIRE(UNIT=IOPER,NAME=NOMFIC) CLOSE(UNIT=IOPER,STATUS='DELETE') * --------------------------------------- * /!\ On ferme immediatement le fichier ouvert par OPTI 'SORT'... * CE N'ETAIT PAS L'APPROCHE GÉNÉRALEMENT ADOPTÉE quand on utilisait * l'opérateur SORTir, mais ici il devient beaucoup plus commode de * procéder ainsi, pour plusieurs raisons : * - éventuellement plusieurs fichiers .vtu seront écrits * - le fichier .pvd peut être ou ne pas être écrit * - les fichiers .vtu peuvent être en mode ASCII ou BINAIRE * - il faut rajouter l'extension ! * --------------------------------------- * On récupère le nom du répertoire dans NOM1, s'il existe IREP=INDEX(NOMFIC,'/',BACK=.TRUE.) NOM1='./' IF (IREP.GT.0) THEN NOM1=NOMFIC(1:IREP) NOMFIC=NOMFIC(IREP+1:LONG(NOMFIC)) ENDIF ************************************************************************ ************************************************************************ ************************************************************************ ************************************************************************ * +---------------------------------------------------------------+ * | | * | L E C T U R E D E S A R G U M E N T S | * | | * +---------------------------------------------------------------+ * NBMAIL :: nombre d'objets 'MAILLAGE' lus * NBCHPO :: nombre d'objets 'CHPOINT' lus * NBCHML :: nombre d'objets 'MCHAML' lus NBMAIL=0 NBCHPO=0 NBCHML=0 SEGINI,SMAIL,SCHPO,SCHML * IPVD=0 :: option 'AUTO' => complétion du .pvd si possible, création d'un nouveau sinon * IPVD=1 :: option 'SUIT' => force la complétion du .pvd (erreur s'il n'existe pas ou s'il est incompatible) * IPVD=2 :: option 'NOUV' => force l'écriture d'un nouveau .pvd * IPVD=3 :: option 'NPVD' => pas de fichier .pvd IPVD=0 * IVTU=0 :: option 'FORMATE' => écriture du .vtu en formaté (ascii) * IVTU=1 :: option 'BINAIRE' => écriture du .vtu en binaire (section AppendedData) * IVTU=2 :: option 'ZIP' => idem que 'BINA', avec compression zlib en plus IVTU=1 * ZTEMP :: option 'TEMP' XTPS=0.D0 ZTEMP=.FALSE. * ZDOUB :: option 'DOUBLE_PRECISION' ZDOUB=.FALSE. FMDAT=FMR4 FLDAT='Float32' ISIZDA=4 * ZOPT1 evite les ambiguites sur la valeur de IPVD * ZOPT2 evite les ambiguites sur la valeur de IVTU ZOPT1=.FALSE. ZOPT2=.FALSE. * (branchement vers les etiquettes de lecture d'objets =LIROBJ) 10 CONTINUE CALL QUETYP(CHA8,0,IRETOU) IF (IRETOU.EQ.0) GOTO 99 ILAB=0 IF (CHA8.EQ.'MAILLAGE') ILAB=1 IF (CHA8.EQ.'CHPOINT' ) ILAB=2 IF (CHA8.EQ.'MCHAML' ) ILAB=3 IF (CHA8.EQ.'TABLE' ) ILAB=4 IF (ILAB.GT.0) GOTO(20,30,40,50),ILAB IF (CHA8.EQ.'MOT') THEN CALL LIRCHA(CHA4,1,LCHA) CALL CHRMOT(MCLE,LMCLE,CHA4,ICLE) IF (ICLE.GT.0) GOTO 11 * ERREUR CRITIQUE 7 (On ne comprend pas le mot %m1:4) MOTERR(1:4)=CHA4 CALL ERREUR(7) RETURN ENDIF * ERREUR CRITIQUE 39 (On ne veut pas d'objet de type %m1:8) MOTERR(1:8)=CHA8 CALL ERREUR(39) RETURN * (branchement vers les étiquettes de traitement des mots-clés) 11 GOTO( 70, 70, 70, 70, 71, 71, 71, 72, 73 ),ICLE * AUTO SUIT NOUV NPVD FORM BINA ZIP TEMP DOUB * ============================================= * LECTURE ET MÉMORISATION D'UN OBJET 'MAILLAGE' * ============================================= 20 CONTINUE * Lecture d'un nouveau MELEME CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU) IF (IERR.NE.0) GOTO 999 * Vérification que le MELEME n'est pas déjà dans la liste DO I1=1,NBMAIL IF (IMAIL(I1).EQ.IPT1) GOTO 60 ENDDO NBMAIL=NBMAIL+1 * Attribution d'un nom par défaut à l'objet lu WRITE(CHA4,FMT='(I4.4)') NBMAIL * Mémorisation des informations SEGADJ,SMAIL IMAIL(NBMAIL)=IPT1 TMAIL(NBMAIL)=CHA4 GOTO 60 * ============================================ * LECTURE ET MÉMORISATION D'UN OBJET 'CHPOINT' * ============================================ 30 CONTINUE * Lecture d'un nouveau CHPOINT CALL LIROBJ('CHPOINT',MCHPO1,1,IRETOU) IF (IERR.NE.0) GOTO 999 * Vérification que le CHPOINT n'est pas déjà dans la liste DO I1=1,NBCHPO IF (ICHPO(I1).EQ.MCHPO1) GOTO 60 ENDDO NBCHPO=NBCHPO+1 * Attribution d'un nom par défaut à l'objet lu CALL QUENOM(CHA8) IF (CHA8.EQ.' ') WRITE(CHA8,FMT='("CHPO",I4.4)') NBCHPO * Mémorisation des informations SEGADJ,SCHPO ICHPO(NBCHPO)=MCHPO1 TCHPO(NBCHPO)=CHA8 GOTO 60 * =========================================== * LECTURE ET MÉMORISATION D'UN OBJET 'MCHAML' * =========================================== 40 CONTINUE * Lecture d'un nouveau MCHAML CALL LIROBJ('MCHAML',MCHEL1,1,IRETOU) IF (IERR.NE.0) GOTO 999 * Vérification que le MCHAML n'est pas déjà dans la liste DO I1=1,NBCHML IF (ICHML(I1).EQ.MCHEL1) GOTO 60 ENDDO NBCHML=NBCHML+1 * Attribution d'un nom par défaut à l'objet lu CALL QUENOM(CHA8) IF (CHA8.EQ.' ') WRITE(CHA8,FMT='("CHML",I4.4)') NBCHML * Mémorisation des informations SEGADJ,SCHML ICHML(NBCHML)=MCHEL1 TCHML(NBCHML)=CHA8 GOTO 60 * =========================================== * LECTURE ET DECOMPOSITION D'UN OBJET 'TABLE' * =========================================== 50 CONTINUE * Lecture d'une TABLE CALL LIROBJ('TABLE',MTABLE,1,IRETOU) IF (IERR.NE.0) GOTO 999 * Décomposition de la TABLE en objets MAILLAGE, CHPOINT et MCHAML SEGACT,MTABLE DO K=MLOTAB,1,-1 * Conversion de l'indice en chaine de caracteres CHA4=MTABTI(K)(1:4) IF (CHA4.EQ.'ENTI') WRITE(CHA8,FMT='(I8.8)') MTABII(K) IF (CHA4.EQ.'FLOT') WRITE(CHA8,FMT='(F8.4)') RMTABI(K) IF (CHA4.EQ.'MOT') THEN CHA8=' ' IF (NBESC.NE.0) SEGACT IPILOC IMO1=IPCHAR(MTABII(K)) IMO2=IPCHAR(MTABII(K)+1) ILON=MIN(8,IMO2-IMO1) CHA8(1:ILON)=ICHARA(IMO1:IMO1+ILON-1) IF (NBESC.NE.0) SEGDES IPILOC ENDIF * Vérification que le type d'objet est valide ITYPOK=0 IF (MTABTV(K).EQ.'MAILLAGE') THEN ITYPOK=4 IF (CHA4.EQ.'ENTI') CHA8(1:4)=CHA8(5:8) IF (CHA4.EQ.'FLOT') CHA8(1:4)=CHA8(2:5) ELSEIF (MTABTV(K).EQ.'CHPOINT'.OR.MTABTV(K).EQ.'MCHAML') THEN ITYPOK=8 ENDIF * Ecriture du nom puis du pointeur vers l'objet IF (ITYPOK.GT.0) THEN CALL ECRCHA(CHA8(1:ITYPOK)) CALL ECROBJ(MTABTV(K),MTABIV(K)) ELSE * ERREUR CRITIQUE 763 (Dans la table %m1:8, l'objet d'indice %m9:16 n'est pas de type %m17:40) CALL QUENOM(CHA8) MOTERR(1:8)=CHA8 WRITE(MOTERR(9:16),FMT='("n°",I6)') K MOTERR(17:40)=' MAILLAGE/CHPOINT/MCHAML' CALL ERREUR(763) RETURN ENDIF ENDDO SEGDES,MTABLE GOTO 10 * ======================================== * ATTRIBUTION D'UN NOM AU DERNIER OBJET LU * ======================================== 60 CONTINUE CALL QUETYP(CHA8,0,IRETOU) IF (IRETOU.NE.0.AND.CHA8.EQ.'MOT') THEN CALL LIRCHA(CHA8,0,LCHA) CALL CHRMOT(MCLE,LMCLE,CHA8(1:4),ICLE) IF (ICLE.GT.0) GOTO 11 * Remarque : On utilise le fait que I1 est incrémenté au passage sur ENDDO * Ainsi, I1 reste figé si on sort prématurement, et vaut bien N+1 * si les N itérations se sont déroulées sans encombre IF (ILAB.EQ.1) THEN TMAIL(I1)='____' TMAIL(I1)(1:LCHA)=CHA8(1:LCHA) ENDIF IF (ILAB.EQ.2) TCHPO(I1)=CHA8 IF (ILAB.EQ.3) TCHML(I1)=CHA8 ENDIF GOTO 10 * ==================== * LECTURE D'UN MOT-CLÉ * ==================== * Mots-clés 'AUTO, 'NOUV', 'SUIT' ou 'NPVD' 70 CONTINUE ICLE1=ICLE-1 IF (ZOPT1.AND.IPVD.NE.ICLE1) THEN * ERREUR CRITIQUE 880 (Syntaxe incorrecte, voir notice) CALL ERREUR(880) WRITE(IOIMP,*) '(options ',MCLE(IPVD),' et ',MCLE(ICLE), . ' incompatibles)' RETURN ENDIF ZOPT1=.TRUE. IPVD=ICLE1 GOTO 10 * Mots-clés 'FORM, 'BINA' ou 'ZIP' 71 CONTINUE ICLE1=ICLE-5 IF (ZOPT2.AND.IVTU.NE.ICLE1) THEN * ERREUR CRITIQUE 880 (Syntaxe incorrecte, voir notice) CALL ERREUR(880) WRITE(IOIMP,*) '(options ',MCLE(IVTU+4),' et ',MCLE(ICLE), . ' incompatibles)' RETURN ENDIF ZOPT2=.TRUE. IVTU=ICLE1 IF (IVTU.EQ.2) THEN * ERREUR CRITIQUE 251 (Tentative d'utilisation d'une option non implémentée) CALL ERREUR(251) WRITE(IOIMP,*) '(option ZIP indisponible pour le moment)' RETURN ENDIF GOTO 10 * Mot-clé 'TEMP' 72 CONTINUE ZTEMP=.TRUE. CALL LIRREE(XTPS,0,IRETOU) IF (IRETOU.EQ.0) THEN * ERREUR CRITIQUE 166 (Le mot-clé %m1:4 n'est pas suivi de la donnée correspondante) MOTERR(1:4)='TEMP' CALL ERREUR(166) RETURN ENDIF GOTO 10 * Mot-clé 'DOUB' 73 CONTINUE ZDOUB=.TRUE. FMDAT=FMR8 FLDAT='Float64' ISIZDA=8 GOTO 10 99 CONTINUE * Vérification : il faut au moins 1 objet MAILLAGE pour continuer IF (NBMAIL.EQ.0) THEN * ERREUR CRITIQUE 37 (On ne trouve pas d'objet de type %m1:8) MOTERR(1:8)='MAILLAGE' CALL ERREUR(37) RETURN ENDIF * Il y a-t-il plusieurs objets MAILLAGE ? ZPART=(NBMAIL.GT.1) * IMPRESSIONS POUR DEBOGAGE * ######################### IF (IIMPI.NE.0) THEN WRITE(IOIMP,FMT='(I2,A)') NBMAIL,' MAILLAGE(s) lu(s)' WRITE(IOIMP,FMT='(5X,I7,2X,A4)') (IMAIL(I),TMAIL(I),I=1,NBMAIL) WRITE(IOIMP,FMT='(I2,A)') NBCHPO,' CHPOINT(s) lu(s)' WRITE(IOIMP,FMT='(5X,I7,2X,A8)') (ICHPO(I),TCHPO(I),I=1,NBCHPO) WRITE(IOIMP,FMT='(I2,A)') NBCHML,' MCHAML(s) lu(s)' WRITE(IOIMP,FMT='(5X,I7,2X,A8)') (ICHML(I),TCHML(I),I=1,NBCHML) ENDIF * ######################### ************************************************************************ ************************************************************************ ************************************************************************ ************************************************************************ * +---------------------------------------------------------------+ * | | * | V É R I F I C A T I O N S D A N S L E . P V D | * | | * +---------------------------------------------------------------+ NOM3=NOM1(1:LONG(NOM1))//NOMFIC(1:LONG(NOMFIC))//'.pvd' INQUIRE(FILE=NOM3,EXIST=ZEXIS) * Option 'AUTO' ou 'SUIT' : on vérifie que le .pvd pré-existant * est compatible avec les données que l'on veut rajouter * (cette vérification n'a pas vocation à être infaillible, elle * permet seulement d'éviter aux étourdis de corrompre le .pvd) * * Après lecture du .pvd : ITF=dernier indice enregistré * XTF=dernier instant enregistré ITF=0 IF (IPVD.LT.2.AND.ZEXIS) THEN OPEN(UNIT = IOXML , . FILE = NOM3 , . STATUS = 'OLD' , . FORM = 'FORMATTED' , . ACCESS = 'SEQUENTIAL', . IOSTAT = IOS ) CALL FINFIC(IOXML) * a) Si 'TEMP' est spécifié, on vérifie que le .pvd contient un * champ 'timestep' et que la chronologie est respectée. Si en * outre plusieurs maillages sont fournis, on vérifie que la * partition est identique (vérif. du nom et du nombre seult.) IF (ZTEMP) THEN * On va devoir vérifier les NBMAIL derniers items (+2 balises de fermeture du .pvd) DO I1=1,NBMAIL+2 BACKSPACE(IOXML) ENDDO DO IMAI=1,NBMAIL * Lecture de l'item puis recherche des champs 'timestep', 'part' et 'file' READ(UNIT=IOXML,FMT='(A)') CBUF II1=INDEX(CBUF,'timestep=') II2=INDEX(CBUF,'part=') II3=INDEX(CBUF,'file='//DQ//NOMFIC(1:LONG(NOMFIC))) * DÉCLENCHEMENT D'UNE ERREUR SI : * - le champ 'file' ne contient pas le nom du fichier lu => 9004 IF (II3.EQ.0) GOTO 9004 * - les NBMAIL derniers items n'ont pas le même 'timestep' => 9001 * - pas de champ 'timestep' trouvé => 9002 * - le 'timestep' lu est supérieur à la valeur spécifiée dans 'TEMP' => 9003 * - le format du fichier n'est pas reconnu => 9004 IF (II1.GT.0) THEN WRITE(MYFMT,FMT='("(",A8,")")') FMDAT READ(CBUF(II1+10:II1+23),FMT=MYFMT,IOSTAT=IOS) XTF IF (IOS.NE.0) GOTO 9004 IF (IMAI.GT.1.AND.XTF1.NE.XTF) GOTO 9001 IF (XTF.GE.XTPS) GOTO 9003 XTF1=XTF ELSE GOTO 9002 ENDIF * - un seul maillage spécifié alors qu'on a trouvé un champ 'part' => 9001 * - plusieurs maillages spécifiés alors qu'on ne trouve aucun champ 'part' => 9001 * - le i-ème champ 'part' n'a pas le même nom que le i-ème maillage spécifié => 9001 * - le format du fichier n'est pas reconnu => 9004 IF (ZPART.AND.(II2.GT.0)) THEN READ(CBUF(II2+6:II2+9),FMT='(A4)',IOSTAT=IOS) CHA4 IF (IOS.NE.0) GOTO 9004 IF (CHA4.NE.TMAIL(IMAI)) GOTO 9001 ELSEIF (ZPART.OR.(II2.GT.0)) THEN GOTO 9001 ENDIF ENDDO * PAS D'ERREUR : on récupère l'indice du dernier p.d.t. CALL LENCHA(NOMFIC,NC) READ(CBUF(II3+NC+7:II3+NC+15),FMT='(A9)',IOSTAT=IOS) CHA9 II4=INDEX(CHA9,'.')-1 WRITE(MYFMT,FMT='("(I",I1,".",I1,")")',IOSTAT=IOS) II4,II4 READ(CHA9(1:II4),FMT=MYFMT,IOSTAT=IO3) ITF IF (IOS.NE.0.OR.II4.EQ.-1) GOTO 9004 * b) Si 'TEMP' est absent, on vérifie que le .pvd ne contient pas * de champ 'timestep' mais uniquement un champ 'part' ELSE BACKSPACE(IOXML) BACKSPACE(IOXML) BACKSPACE(IOXML) * Lecture du dernier item puis recherche des champs 'timestep' et 'part' READ(UNIT=IOXML,FMT='(A)') CBUF II1=INDEX(CBUF,'timestep=') II2=INDEX(CBUF,'part=') * DÉCLENCHEMENT D'UNE ERREUR SI : * - un champ 'timestep' est trouvé => 9005 * - aucun champ 'part' ni 'timestep' n'est trouvé => 9004 IF (II1.GT.0) GOTO 9005 IF (II2.EQ.0) GOTO 9004 ENDIF CLOSE(UNIT=IOXML) ENDIF * Pas d'erreur => on passe à la suite GOTO 9000 * MESSAGES D'ERREUR : fichier .pvd incompatible et option 'SUIT' * *************************************************************** * ERREUR CRITIQUE 26 (Tache impossible. Probablement données erronées) 9001 IF (IPVD.EQ.0) GOTO 9050 CALL ERREUR(26) WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe déjà et la ', . 'partition spécifiée diffère du p.d.t. précédent' GOTO 999 9002 IF (IPVD.EQ.0) GOTO 9050 CALL ERREUR(26) WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe déjà et ', . 'n''est pas compatible avec l''option ''TEMP''' GOTO 999 9003 IF (IPVD.EQ.0) GOTO 9050 CALL ERREUR(26) WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe déjà et la ', . 'valeur spécifiée pour ''TEMP'' est trop petite' GOTO 999 9004 IF (IPVD.EQ.0) GOTO 9050 CALL ERREUR(26) WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe déjà mais ', . 'il semble corrompu...' GOTO 999 9005 IF (IPVD.EQ.0) GOTO 9050 CALL ERREUR(26) WRITE(IOIMP,*) 'VTK ''SUIT'' : le fichier existe déjà et ', . 'requiert l''utilisation du mot-clé ''TEMP''' GOTO 999 * *************************************************************** * Fichier .pvd incompatible et option 'AUTO' * => on continue mais le .pvd existant sera écrasé 9050 ZEXIS=.FALSE. ************************************************************************ ************************************************************************ ************************************************************************ ************************************************************************ * +---------------------------------------------------------------+ * | | * | É C R I T U R E D E S F I C H I E R S . V T U | * | | * +---------------------------------------------------------------+ 9000 CONTINUE * Lorsqu'il y a déjà deux unités logiques XDR ouvertes (REST et * SAUV en l'occurence), l'ouverture d'une troisième unité engendre * un bug critique (redémarrage du jeu de données !). On s'assure * que le fichier de RESTitution est bien fermé pour éviter cela. IF (IVTU.GT.0.AND.IXDRR.NE.0) THEN CALL IXDRCLOSE(IXDRR,.TRUE.) IXDRR=0 ENDIF * Préparation de l'entête des fichiers CALL GIBDAT(IJOUR,IMOIS,IANNEE) IANNEE=MOD(IANNEE,100)+2000 CALL GIBNAM(CHA8) CALL NETCHA(CHA8) WRITE(CHEAD,FMT='(A,I2.2,A1,I2.2,A1,I4,A)') . '' CALL LENCHA(CHEAD,LHEAD) * --------------------- * NOM DES FICHIERS .vtu * --------------------- * * repetoire/ nom_de_base.XXXXxxxx.YYYY.vtu * |__________||___________| * NOM1 NOMFIC | * |____________________| | * NOM2 | * |_____________________________| * NOM3 * * - XXXXxxxx : /!\ SEULEMENT SI L'OPTION 'TEMP' EST PRÉSENTE * => entier écrit sur 4 à 8 caractères et incrémenté * à chaque pas de temps sorti * * - YYYY : /!\ SEULMENT SI PLUSIEURS MAILLAGES SONT FOURNIS * OU SI ON SORT UN .PVD SANS OPTION 'TEMP' * => chaine de 4 caractères alpha-numériques indiquant * le nom de la partition géométrie sortie * NOM2=NOMFIC IF (ZTEMP) THEN IPDT=ITF+1 WRITE(CHA8,FMT='(I8.8)') IPDT LPDT=MAX(4,INT(LOG10(DBLE(IPDT)))+1) NOM2=NOM2(1:LONG(NOM2))//'.'//CHA8(9-LPDT:8) ENDIF * (BOUCLE SUR LES MAILLAGES) DO 100 IMAI=1,NBMAIL * ============================================================= * 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 * ============================================================= * Détermination du nom complet du fichier .vtu NOM3=NOM1(1:LONG(NOM1))//NOM2 IF ((.NOT.ZTEMP.AND.IPVD.LT.3).OR.ZPART) THEN NOM3=NOM3(1:LONG(NOM3))//'.'//TMAIL(IMAI) ENDIF NOM3=NOM3(1:LONG(NOM3))//'.vtu' * Commande d'ouverture du fichier XML OPEN(UNIT = IOXML, . FILE = NOM3, . STATUS = 'UNKNOWN', . FORM = 'FORMATTED', . ACCESS = 'SEQUENTIAL', . IOSTAT = IOS) * Commande d'ouverture du fichier binaire IF (IVTU.GT.0) THEN IOBIN=INITXDR(NOM3(1:LONG(NOM3))//'.bin','w',.FALSE.) * Début de la section binaire AppendedData CALL IXDRINT(IOBIN,IXDR1) IPOS=0 ENDIF * Ecriture des entêtes WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . CHEAD(1:LHEAD) IF (IVTU.EQ.0) THEN WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . '' ELSE WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . '' ENDIF WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) . '' * ============================================================= * D O N N É E S G É O M É T R I Q U E S * ============================================================= * NEL = nombre d'éléments du maillage au total * NNO = nombre de noeuds du maillage au total * NBSOU = nombre de sous-maillages (un par type d'élément) IPT1=IMAIL(IMAI) SEGACT,IPT1 NBSOU=IPT1.LISOUS(/1) NBSOU1=MAX(1,NBSOU) * Pour chaque MAILLAGE passé en argument, on doit : * - remplir les tables de correspondance LOCAL <--> GLOBAL * - déterminer le nombre de noeuds au total * - déterminer le nombre d'éléments au total * - mémoriser les caractéristiques des cellules (connectivité, * offset, type d'élément VTK) * - si des MCHAML sont à sortir, mémoriser le type et le nombre * d'éléments dans chaque sous-maillage NEL=0 NEL1=0 NNO=0 NBCON=0 IOF=0 SEGINI,IPOG2L,IOFFS,ITYEL,ICONN IF (NBCHML.GT.0) SEGINI,ITYPII,INECUM * (BOUCLE SUR LES SOUS-MAILLAGES) IPT2=IPT1 DO ISOU=1,NBSOU1 IF (NBSOU.GT.0) THEN IPT2=IPT1.LISOUS(ISOU) SEGACT,IPT2 ENDIF * L'élément est-il représentable par VTK ? ITYP=IPT2.ITYPEL ITY=ITYVTK(ITYP) IF (ITY.EQ.0) THEN * ERREUR CRITIQUE 21 (Données incompatibles) CALL ERREUR(21) WRITE(IOIMP,*) 'Le maillage ',TMAIL(IMAI), . ' comporte des éléments ',NOMS(ITYP), . ' incompatibles avec VTK' GOTO 999 ENDIF * On mémorise les infos ci-dessous pour aller plus vite * lors du traitement ultérieur des MCHAML IF (NBCHML.GT.0) THEN ITYPII(ITYP)=ISOU INECUM(ISOU)=NEL ENDIF * (BOUCLE SUR LES ÉLÉMENTS DU SOUS-MAILLAGE) NN1=IPT2.NUM(/1) NN2=IPT2.NUM(/2) NEL=NEL+NN2 NEL1=NEL NBCON=NBCON+(NN1*NN2) SEGADJ,ICONN,IOFFS,ITYEL DO I2=1,NN2 DO I1=1,NN1 IF (ITY.GE.20) THEN * Correction pour les elements quadratiques I3 = INUVTK(I1,ITY-20) ELSE I3 = I1 ENDIF INUM=IPT2.NUM(I3,I2) IPOG2L(INUM)=1 ICONN(IOF+I1)=INUM ENDDO IOF=IOF+NN1 IOFFS(NEL-NN2+I2)=IOF ITYEL(NEL-NN2+I2)=ITY ENDDO IF (NBSOU.GT.0) SEGDES,IPT2 ENDDO * (BOUCLE SUR LA TABLE GLOBALE IPOG2L) NNO=NBCON SEGINI,IPOL2G NNO=0 DO I3=1,NPMAX IF (IPOG2L(I3).EQ.1) THEN NNO=NNO+1 IPOL2G(NNO)=I3 IPOG2L(I3)=NNO ENDIF ENDDO IF (NNO.NE.NBCON) SEGADJ,IPOL2G c * ÉCRITURE DANS LE FICHIER * ************************************************************* * ************************************************************* WRITE(CNU1,FMT='(I15)') NNO WRITE(CNU2,FMT='(I15)') NEL CALL LIMCHA(CNU1,ID1,IF1) CALL LIMCHA(CNU2,ID2,IF2) WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS) . '' * ***************************************************** * S E C T I O N P O I N T S * ***************************************************** WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' * ===================== FORMATÉ ===================== IF (IVTU.EQ.0) THEN WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' DO IK=1,NNO II=IPOL2G(IK)-1 XRE8=XCOOR(II*IDIM1+1) YRE8=XCOOR(II*IDIM1+2) ZRE8=0.D0 IF (IDIM.EQ.3) ZRE8=XCOOR(II*IDIM1+3) WRITE(MYFMT,FMT='("(20X,3",A8,")")') FMDAT WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . XRE8,YRE8,ZRE8 ENDDO WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' * ===================== BINAIRE ===================== ELSE NBYTES=(3*NNO)*ISIZDA WRITE(CNU1,FMT='(I15)') IPOS IPOS=IPOS+ISIZNB+NBYTES CALL LIMCHA(CNU1,ID1,IF1) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' CALL IXDRINT(IOBIN,NBYTES) IF (ZDOUB) THEN DO IK=1,NNO II=IPOL2G(IK)-1 XRE8=XCOOR(II*IDIM1+1) YRE8=XCOOR(II*IDIM1+2) ZRE8=0.D0 IF (IDIM.EQ.3) ZRE8=XCOOR(II*IDIM1+3) CALL IXDRDOUBLE(IOBIN,XRE8) CALL IXDRDOUBLE(IOBIN,YRE8) CALL IXDRDOUBLE(IOBIN,ZRE8) ENDDO ELSE DO IK=1,NNO II=IPOL2G(IK)-1 XRE4=XCOOR(II*IDIM1+1) YRE4=XCOOR(II*IDIM1+2) ZRE4=0. IF (IDIM.EQ.3) ZRE4=XCOOR(II*IDIM1+3) CALL IXDRREAL(IOBIN,XRE4) CALL IXDRREAL(IOBIN,YRE4) CALL IXDRREAL(IOBIN,ZRE4) ENDDO ENDIF ENDIF WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' * ***************************************************** * S E C T I O N C E L L S * ***************************************************** WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' * ===================== FORMATÉ ===================== IF (IVTU.EQ.0) THEN WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(20X,8I10)',IOSTAT=IOS) . ((IPOG2L(ICONN(K))-1),K=1,ICONN(/1)) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' * ---------------------- WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(20X,8I10)',IOSTAT=IOS) . (IOFFS(K),K=1,NEL) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' * ---------------------- WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(20X,20I4)',IOSTAT=IOS) . (ITYEL(K),K=1,NEL) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' * ===================== BINAIRE ===================== ELSE NBYTES=ICONN(/1)*4 WRITE(CNU1,FMT='(I15)') IPOS IPOS=IPOS+ISIZNB+NBYTES CALL LIMCHA(CNU1,ID1,IF1) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' CALL IXDRINT(IOBIN,NBYTES) DO K=1,ICONN(/1) CALL IXDRINT(IOBIN,IPOG2L(ICONN(K))-1) ENDDO * ---------------------- NBYTES=NEL*4 WRITE(CNU1,FMT='(I15)') IPOS IPOS=IPOS+ISIZNB+NBYTES CALL LIMCHA(CNU1,ID1,IF1) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' CALL IXDRINT(IOBIN,NBYTES) DO K=1,NEL CALL IXDRINT(IOBIN,IOFFS(K)) ENDDO * ---------------------- * Groupement de quatre UInt8 en un seul Int32 * (pour prendre moins de place !) NBYTES=NEL NBTROP=NEL-(NBYTES/4)*4 IF (NBTROP.GT.0) THEN NEL1=NEL+4-NBTROP SEGADJ,ITYEL NBYTES=NEL1 ENDIF WRITE(CNU1,FMT='(I15)') IPOS IPOS=IPOS+ISIZNB+NBYTES CALL LIMCHA(CNU1,ID1,IF1) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' CALL IXDRINT(IOBIN,NBYTES) K20=0 DO K2=1,(NBYTES/4) IXDR3=0 DO K1=1,4 IXDR3=IXDR3+(256**(4-K1))*ITYEL(K20+K1) ENDDO CALL IXDRINT(IOBIN,IXDR3) K20=K20+4 ENDDO ENDIF WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' * ************************************************************* * ************************************************************* * FIN D'ÉCRITURE DANS LE FICHIER SEGSUP,IPOL2G,ICONN,IOFFS,ITYEL * ============================================================= * G R A N D E U R S D É F I N I E S A U X N O E U D S * ============================================================= WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' * (BOUCLE SUR LES CHAMPS PAR POINTS) DO 200 ICHP=1,NBCHPO MCHPO1=ICHPO(ICHP) SEGACT,MCHPO1 * NSOUPO = Nombre de sous-champs NSOUPO=MCHPO1.IPCHP(/1) IF (NSOUPO.EQ.0) GOTO 200 * 1) CRÉATION DE LA LISTE DES COMPOSANTES DANS TCHCO * On crée cette liste avant toute chose et non pas au fur * et à mesure pour éviter de faire des SEGADJ sur le gros * segment SCHPV JGN=4 JGM=0 SEGINI,TCHCO DO I1=1,NSOUPO MSOUP1=MCHPO1.IPCHP(I1) SEGACT,MSOUP1 NC=MSOUP1.NOCOMP(/2) JGM1=JGM DO 210 I2=1,NC CHA4=MSOUP1.NOCOMP(I2) DO I3=1,JGM1 IF (TCHCO.MOTS(I3).EQ.CHA4) GOTO 210 ENDDO JGM=JGM+1 SEGADJ,TCHCO TCHCO.MOTS(JGM)=CHA4 210 CONTINUE SEGDES,MSOUP1 ENDDO * 2) CONCATÉNATION DE TOUS LES VPOCHA DANS XPOCHA * - on écrase la structure compliquée du CHPOINT dans un simple tableau (n°comp.;n°noeud) * - on passe de la numérotation globale à la numérotation locale NCO=JGM SEGINI,SCHPV,ICOOK DO 220 ISOU=1,NSOUPO MSOUP1=MCHPO1.IPCHP(ISOU) SEGACT,MSOUP1 MPOVA1=MSOUP1.IPOVAL IF (MPOVA1.EQ.0) GOTO 219 SEGACT,MPOVA1 IPT2=MSOUP1.IGEOC IF (IPT2.EQ.0) GOTO 218 SEGACT,IPT2 NN1=MPOVA1.VPOCHA(/1) NC1=MPOVA1.VPOCHA(/2) DO I1=1,NC1 * Recherche de la composante dans la liste TCHCO CHA4=MSOUP1.NOCOMP(I1) DO ICO=1,NCO IF (TCHCO.MOTS(ICO).EQ.CHA4) GOTO 240 ENDDO * MISE À JOUR DE SCHPV * - si un noeud du support du SOUPO n'appartient pas au maillage courant, on passe au suivant * - si un noeud du MAILLAGE courant n'est pas présent dans le support du SOUPO, sa valeur reste à zéro 240 NTROUV=0 DO 250 I2=1,NN1 INO=IPOG2L(IPT2.NUM(1,I2)) IF (INO.EQ.0) GOTO 250 SCHPV.XPOCHA(ICO,INO)=SCHPV.XPOCHA(ICO,INO) & +MPOVA1.VPOCHA(I2,I1) NTROUV=1 250 CONTINUE IF (NTROUV.EQ.1) CALL AJOU(ICOOK,ICO) ENDDO SEGDES,IPT2 218 SEGDES,MPOVA1 219 SEGDES,MSOUP1 220 CONTINUE SEGDES,MCHPO1 * S'il n'y a rien à sortir, on passe au CHPOINT suivant NCOK=ICOOK(/1) IF (NCOK.EQ.0) GOTO 299 IF (NCOK.LT.NCO) CALL ORDO01(ICOOK(1),NCOK,.TRUE.) * ÉCRITURE DANS LE FICHIER * ********************************************************* * ********************************************************* WRITE(MYFMT,FMT='("(16X,A,",I2,"A5,A)")') NCOK WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . '' CHA8=TCHPO(ICHP) * ===================== FORMATÉ ===================== IF (IVTU.EQ.0) THEN WRITE(CNU1,FMT='(I15)') NCOK CALL LIMCHA(CNU1,ID1,IF1) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' WRITE(MYFMT,FMT='("(20X,",I2,A8,")")') NCOK,FMDAT WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . ((SCHPV.XPOCHA(ICOOK(K),J),K=1,NCOK),J=1,NNO) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' * ===================== BINAIRE ===================== ELSE NBYTES=(NCOK*NNO)*ISIZDA WRITE(CNU1,FMT='(I15)') IPOS IPOS=IPOS+ISIZNB+NBYTES WRITE(CNU2,FMT='(I15)') NCOK CALL LIMCHA(CNU1,ID1,IF1) CALL LIMCHA(CNU2,ID2,IF2) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' CALL IXDRINT(IOBIN,NBYTES) IF (ZDOUB) THEN DO J=1,NNO DO K=1,NCOK XRE8=SCHPV.XPOCHA(ICOOK(K),J) CALL IXDRDOUBLE(IOBIN,XRE8) ENDDO ENDDO ELSE DO J=1,NNO DO K=1,NCOK XRE4=SCHPV.XPOCHA(ICOOK(K),J) CALL IXDRREAL(IOBIN,XRE4) ENDDO ENDDO ENDIF ENDIF * ********************************************************* * ********************************************************* * FIN D'ÉCRITURE DANS LE FICHIER 299 SEGSUP,SCHPV,TCHCO,ICOOK 200 CONTINUE * (FIN DE LA BOUCLE SUR LES CHAMPS PAR POINTS) WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' SEGSUP,IPOG2L * ============================================================= * G R A N D E U R S D É F I N I E S P A R É L É M E N T * ============================================================= WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' * (BOUCLE SUR LES CHAMPS PAR ÉLÉMENTS) DO 300 ICHE=1,NBCHML MCHEL1=ICHML(ICHE) SEGACT,MCHEL1 * NSOCHA = Nombre de sous-champs NSOCHA=MCHEL1.ICHAML(/1) IF (NSOCHA.EQ.0) GOTO 300 * 1) CRÉATION DE LA LISTE DES COMPOSANTES DANS TCHCO * On crée cette liste avant toute chose et non pas au fur * et à mesure pour éviter de faire des SEGADJ sur le gros * segment SCHMV * + VÉRIFICATIONS SUR LE TYPE DE MCHAML JGN=8 JGM=0 SEGINI,TCHCO DO I1=1,NSOCHA MCHAM1=MCHEL1.ICHAML(I1) SEGACT,MCHAM1 NC1=MCHAM1.IELVAL(/1) JGM1=JGM DO 310 I2=1,NC1 * VÉRIFICATION 1 : composante de type scalaire ? IF (MCHAM1.TYPCHE(I2).NE.'REAL*8') THEN * ERREUR CRITIQUE 679 (Le type de la composante %m1:8 du MCHAML est incorrect) MOTERR(1:8)=MCHAM1.NOMCHE(I2) CALL ERREUR(679) WRITE(IOIMP,*) '(le champ par éléments "', . TCHML(ICHE),'" contient des ', . 'composantes non scalaires' GOTO 999 ENDIF * VÉRIFICATION 2 : une seule valeur par cellule ? MELVA1=MCHAM1.IELVAL(I2) SEGACT,MELVA1 IF (MELVA1.VELCHE(/1).NE.1) THEN * ERREUR CRITIQUE 707 (Le MCHAML doit contenir une valeur (de chaque composante) par élément) CALL ERREUR(707) WRITE(IOIMP,*) '(le champ par éléments "', . TCHML(ICHE),'" n''est pas de', . ' type "GRAVITE")' GOTO 999 ENDIF SEGDES,MELVA1 * CRÉATION DE LA LISTE TCHCO CHA8=MCHAM1.NOMCHE(I2) DO I3=1,JGM1 IF (TCHCO.MOTS(I3).EQ.CHA8) GOTO 310 ENDDO JGM=JGM+1 SEGADJ,TCHCO TCHCO.MOTS(JGM)=CHA8 310 CONTINUE SEGDES,MCHAM1 ENDDO * 2) CONCATÉNATION DE TOUS LES VELCHE DANS XELCHE * - on écrase la structure compliquée du MCHAML dans un simple tableau (n°comp.;n°cell.) * - on passe de la numérotation globale à la numérotation locale NCO=JGM SEGINI,SCHMV,ICOOK DO 320 I1=1,NSOCHA MCHAM1=MCHEL1.ICHAML(I1) SEGACT,MCHAM1 * IPT2 = SUPPORT DU SOUS-CHAMP DU MCHAML IPT2=MCHEL1.IMACHE(I1) SEGACT,IPT2 ITYP2=IPT2.ITYPEL ITY2=ITYVTK(ITYP2) IF (ITY2.EQ.0) THEN C ERREUR CRITIQUE 21 (Données incompatibles) CALL ERREUR(21) WRITE(IOIMP,*) 'Le champ "',TCHML(ICHE), . '" s''appuye sur des éléments ', . NOMS(ITYP),' incompatibles avec VTK' GOTO 999 ENDIF NEL2=IPT2.NUM(/2) * IPT3 = SOUS-MELEME DU MAILLAGE COURANT CONSTITUE DU * MEME TYPE D'ELEMENTS QUE IPT2 I3=ITYPII(ITYP2) IF (I3.EQ.0) GOTO 319 IPT3=IPT1 IF (NBSOU.GT.0) THEN IPT3=IPT1.LISOUS(I3) SEGACT,IPT3 ENDIF NNN3=IPT3.NUM(/1) NEL3=IPT3.NUM(/2) * On cherche pour chaque élément de IPT2 un élément de * IPT3 qui possède les mêmes noeuds, dans le même ordre SEGINI,IELL2G DO 330 IEL2=1,NEL2 DO 331 IEL3=1,NEL3 DO INO=1,NNN3 INUM2=IPT2.NUM(INO,IEL2) INUM3=IPT3.NUM(INO,IEL3) IF (INUM2.NE.INUM3) GOTO 331 ENDDO * ON A TROUVÉ UN ÉLÉMENT COMMUN A IPT2 ET IPT3 IELL2G(IEL2)=INECUM(I3)+IEL3 GOTO 330 331 CONTINUE 330 CONTINUE * Remplissage de SCHMV pour chaque composante du SOCHA DO 340 J1=1,NCO MELVA1=MCHAM1.IELVAL(J1) IF (MELVA1.EQ.0) GOTO 340 SEGACT,MELVA1 NBVAL=MELVA1.VELCHE(/2) * Recherche de la composante dans la liste TCHCO CHA8=MCHAM1.NOMCHE(J1) DO ICO=1,NCO IF (TCHCO.MOTS(ICO).EQ.CHA8) GOTO 350 ENDDO * MISE À JOUR DE SCHMV * - si une cellule du support du SOCHA n'appartient pas au maillage courant, on passe à la suivante * - si une cellule du MAILLAGE courant n'est pas présente dans le support du SOCHA, sa valeur reste à zéro 350 NTROUV=0 DO 360 J2=1,NEL2 IEL=IELL2G(J2) IF (IEL.EQ.0) GOTO 360 IF (NBVAL.EQ.1) THEN * ATTENTION, le MELVA1 est uniforme ! SCHMV.XELCHE(ICO,IEL)=MELVA1.VELCHE(1,1) ELSE SCHMV.XELCHE(ICO,IEL)=MELVA1.VELCHE(1,J2) ENDIF NTROUV=1 360 CONTINUE IF (NTROUV.EQ.1) CALL AJOU(ICOOK,ICO) SEGDES,MELVA1 340 CONTINUE SEGSUP,IELL2G * /!\ IPT2 et IPT3 peuvent être égaux à IPT1, or IPT1 doit rester actif !! IF (NBSOU.GT.0) SEGDES,IPT3 319 IF (IPT2.NE.IPT1) SEGDES,IPT2 SEGDES,MCHAM1 320 CONTINUE SEGDES,MCHEL1 * S'il n'y a rien à sortir, on passe au MCHAML suivant NCOK=ICOOK(/1) IF (NCOK.EQ.0) GOTO 399 IF (NCOK.LT.NCO) CALL ORDO01(ICOOK(1),NCOK,.TRUE.) * ÉCRITURE DANS LE FICHIER * ********************************************************* * ********************************************************* WRITE(MYFMT,FMT='("(16X,A,",I2,"A9,A)")') NCOK WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . '' CHA8=TCHML(ICHE) * ===================== FORMATÉ ===================== IF (IVTU.EQ.0) THEN WRITE(CNU1,FMT='(I15)') NCOK CALL LIMCHA(CNU1,ID1,IF1) WRITE(UNIT=IOXML,FMT='(16X,A,I2,A)',IOSTAT=IOS) . '' WRITE(MYFMT,FMT='("(20X,",I2,A8,")")') NCOK,FMDAT WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . ((SCHMV.XELCHE(ICOOK(K),J),K=1,NCOK),J=1,NEL) WRITE(UNIT=IOXML,FMT='(16X,A)',IOSTAT=IOS) . '' * ===================== BINAIRE ===================== ELSE NBYTES=(NCOK*NEL)*ISIZDA WRITE(CNU1,FMT='(I15)') IPOS IPOS=IPOS+ISIZNB+NBYTES WRITE(CNU2,FMT='(I15)') NCOK CALL LIMCHA(CNU1,ID1,IF1) CALL LIMCHA(CNU2,ID2,IF2) WRITE(UNIT=IOXML,FMT='(16X,A,I2,A)',IOSTAT=IOS) . '' CALL IXDRINT(IOBIN,NBYTES) IF (ZDOUB) THEN DO J=1,NEL DO K=1,NCOK XRE8=SCHMV.XELCHE(ICOOK(K),J) CALL IXDRDOUBLE(IOBIN,XRE8) ENDDO ENDDO ELSE DO J=1,NEL DO K=1,NCOK XRE4=SCHMV.XELCHE(ICOOK(K),J) CALL IXDRREAL(IOBIN,XRE4) ENDDO ENDDO ENDIF ENDIF * ********************************************************* * ********************************************************* * FIN D'ÉCRITURE DANS LE FICHIER 399 SEGSUP,SCHMV,TCHCO,ICOOK 300 CONTINUE * (FIN DE LA BOUCLE SUR LES CHAMPS PAR ÉLÉMENTS) WRITE(UNIT=IOXML,FMT='(12X,A)',IOSTAT=IOS) . '' SEGDES,IPT1 IF (NBCHML.GT.0) SEGSUP,ITYPII,INECUM * ============================================================= * F E R M E T U R E D U F I C H I E R . V T U * ============================================================= WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) . '' * CAS DES FICHIERS BINAIRES (OPTIONS 'BINA' OU 'ZIP') * On doit recopier le contenu du fichier .bin dans la balise * du fichier .vtu IF (IVTU.GT.0) THEN WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) . '' * Changement de mode d'écriture ASCII->BINAIRE pour le .vtu CLOSE(UNIT=IOXML) IOBIN2=INITXDR(NOM3,'a',.FALSE.) * Relecture et copie du fichier binaire * (par paquets de 4 octets, "brique de base" de XDR) CALL IXDRCLOSE(IOBIN,.FALSE.) IOBIN=INITXDR(NOM3(1:LONG(NOM3))//'.bin','r',.FALSE.) DO I=1,(1+(IPOS/4)) CALL IXDRINT(IOBIN ,INT4) CALL IXDRINT(IOBIN2,INT4) ENDDO * Suppression du fichier binaire temporaire CALL IXDRCLOSE(IOBIN,.FALSE.) OPEN(UNIT = IOBIN, . FILE = NOM3(1:LONG(NOM3))//'.bin') CLOSE(UNIT=IOBIN,STATUS='DELETE') * Insertion des marqueurs EOR et EOF pour que le contenu de * la section binaire ne soit pas écrasé lors de la fermeture * de la balise (effectuée ci-après) CALL IXDRINT(IOBIN2,IXDR2) CALL IXDRINT(IOBIN2,IXDR2) * Changement de mode d'écriture BINAIRE->ASCII pour le .vtu CALL IXDRCLOSE(IOBIN2,.FALSE.) OPEN(UNIT = IOXML , . FILE = NOM3 , . STATUS = 'UNKNOWN' , . FORM = 'FORMATTED' , . ACCESS = 'SEQUENTIAL' , . IOSTAT = IOS ) CALL FINFIC(IOXML) WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) . '' ENDIF WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . '' CLOSE(UNIT=IOXML) 100 CONTINUE * (FIN DE LA BOUCLE SUR LES MAILLAGES) ************************************************************************ ************************************************************************ ************************************************************************ ************************************************************************ * +---------------------------------------------------------------+ * | | * | É C R I T U R E D U F I C H I E R . P V D | * | | * +---------------------------------------------------------------+ * Nom du fichier .pvd NOM3=NOM1(1:LONG(NOM1))//NOMFIC(1:LONG(NOMFIC))//'.pvd' * 1) Option 'NPVD' * => fin de la subroutine IF (IPVD.EQ.3) GOTO 999 * 2) Option 'AUTO' ou 'SUIT' quand le .pvd existe et est compatible * => on complète le .pvd IF (IPVD.LT.2.AND.ZEXIS) THEN * On se place à la fin du fichier existant puis... OPEN(UNIT = IOXML , . FILE = NOM3 , . STATUS = 'OLD' , . FORM = 'FORMATTED' , . ACCESS = 'SEQUENTIAL' , . IOSTAT = IOS ) CALL FINFIC(IOXML) * ...on recule de 2 enregistrements pour écraser les balises de * fermeture BACKSPACE(IOXML) BACKSPACE(IOXML) * 3) Option 'NOUV', ou pas de fichier existant et compatible * => on crée le .pvd (ou on l'écrase) ELSE OPEN(UNIT = IOXML , . FILE = NOM3 , . STATUS = 'UNKNOWN' , . FORM = 'FORMATTED' , . ACCESS = 'SEQUENTIAL' , . IOSTAT = IOS ) REWIND(IOXML) WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . CHEAD(1:LHEAD) WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) . '' WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) . '' ENDIF WRITE(MYFMT,FMT='("(8X,A,",A8,",A)")') FMDAT DO IMAI=1,NBMAIL * Nom de chaque fichier .vtu créé par cette exécution de la subroutine NOM3=NOM2 IF ((.NOT.ZTEMP.AND.IPVD.LT.3).OR.ZPART) THEN NOM3=NOM3(1:LONG(NOM3))//'.'//TMAIL(IMAI) ENDIF NOM3=NOM3(1:LONG(NOM3))//'.vtu' * ECRITURE DE LA LIGNE CORRESPONDANTE DANS LA COLLECTION * - champ 'timestep' : seulement avec l'option 'TEMP' * - champ 'part' : en l'absence de 'TEMP', ou si plusieurs maillages étaient fournis * - champ 'file' : toujours !! IF (ZTEMP) THEN IF (ZPART) THEN WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . '' ELSE WRITE(UNIT=IOXML,FMT=MYFMT,IOSTAT=IOS) . '' ENDIF ELSE WRITE(UNIT=IOXML,FMT='(8X,A)',IOSTAT=IOS) . '' ENDIF ENDDO WRITE(UNIT=IOXML,FMT='(4X,A)',IOSTAT=IOS) '' WRITE(UNIT=IOXML,FMT='(A)',IOSTAT=IOS) '' CLOSE(UNIT=IOXML) ************************************************************************ ************************************************************************ ************************************************************************ ************************************************************************ * +---------------------------------------------------------------+ * | | * | F I N D E L A S U B R O U T I N E | * | | * +---------------------------------------------------------------+ 999 CONTINUE SEGDES,SMAIL,SCHPO,SCHML RETURN END