1C* This file is part of MED. 2C* 3C* COPYRIGHT (C) 1999 - 2019 EDF R&D, CEA/DEN 4C* MED is free software: you can redistribute it and/or modify 5C* it under the terms of the GNU Lesser General Public License as published by 6C* the Free Software Foundation, either version 3 of the License, or 7C* (at your option) any later version. 8C* 9C* MED is distributed in the hope that it will be useful, 10C* but WITHOUT ANY WARRANTY; without even the implied warranty of 11C* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12C* GNU Lesser General Public License for more details. 13C* 14C* You should have received a copy of the GNU Lesser General Public License 15C* along with MED. If not, see <http://www.gnu.org/licenses/>. 16C* 17 18C ******************************************************************************* 19C * - Nom du fichier : test26.f 20C * 21C * - Description : lecture de mailles MED_POLYEDRE dans le maillage MED 22C * du fichier test25.med 23C * 24C ****************************************************************************** 25 program test26 26C 27 implicit none 28 include 'med.hf' 29C 30 integer*8 fid 31 integer cret,mdim,nmaa,npoly,i,j,k,l,nfindex 32 integer edim,nstep,stype,atype, chgt, tsf 33 integer nfaces, nnoeuds 34 integer ind1, ind2 35 character*64 maa 36 character*200 desc 37 integer n 38 parameter (n=2) 39 integer np,nf,np2,nf2,taille,tmp 40 parameter (np=3,nf=9,np2=3,nf2=8) 41 integer indexp(np),indexf(nf) 42 integer conn(24) 43 integer indexp2(np2),indexf2(nf2) 44 integer conn2(nf2) 45 character*16 nom(n) 46 integer num(n),fam(n) 47 integer type 48 character*16 nomcoo(3) 49 character*16 unicoo(3) 50 character(16) :: dtunit 51C 52C Ouverture du fichier test25.med en lecture seule 53 call mfiope(fid,'test25.med',MED_ACC_RDONLY, cret) 54 print *,cret 55 if (cret .ne. 0 ) then 56 print *,'Erreur ouverture du fichier' 57 call efexit(-1) 58 endif 59 print *,'Ouverture du fichier test25.med' 60C 61C Combien de maillage 62 call mmhnmh(fid,nmaa,cret) 63 print *,cret 64 if (cret .ne. 0 ) then 65 print *,'Erreur lecture du nombre de maillage' 66 call efexit(-1) 67 endif 68 print *,'Nombre de maillages : ',nmaa 69C 70C Lecture de toutes les mailles MED_POLYEDRE 71C dans chaque maillage 72 do 10 i=1,nmaa 73C 74C Info sur chaque maillage 75 call mmhmii(fid,i,maa,edim,mdim,type,desc, 76 & dtunit,stype,nstep,atype, 77 & nomcoo,unicoo,cret) 78 print *,cret 79 if (cret .ne. 0 ) then 80 print *,'Erreur infos maillage' 81 call efexit(-1) 82 endif 83 print *,'Maillage : ',maa 84 print *,'Dimension : ',mdim 85C 86C Combien de mailles polyedres a partir de la taille du tableau 87C d'indexation des faces en connectivite nodale 88 call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT, 89 & MED_CELL,MED_POLYHEDRON,MED_INDEX_FACE,MED_NODAL, 90 & chgt,tsf,nfindex,cret) 91 npoly = nfindex - 1 92 print *,cret 93 if (cret .ne. 0 ) then 94 print *,'Erreur lecture nombre de polyedre' 95 call efexit(-1) 96 endif 97 print *,'Nombre de mailles MED_POLYEDRE : ',npoly 98C 99C Taille des connectivites et du tableau d'indexation des faces 100C en connectivite nodale 101 call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT, 102 & MED_CELL,MED_POLYHEDRON, 103 & MED_INDEX_NODE,MED_NODAL, 104 & chgt,tsf,taille,cret) 105 print *,cret 106 if (cret .ne. 0 ) then 107 print *,'Erreur infos sur les polyedres' 108 call efexit(-1) 109 endif 110 print *,'Taille de la connectivite : ',taille 111 print *,'Taille du tableau indexf : ', nfindex 112C 113C Lecture de la connectivite en mode nodal 114 call mmhphr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL, 115 & MED_NODAL,indexp,indexf,conn,cret) 116 print *,cret 117 if (cret .ne. 0 ) then 118 print *,'Erreur lecture connectivites polyedres' 119 call efexit(-1) 120 endif 121 print *,'Lecture de la connectivite des polyedres' 122 print *,'Connectivite nodale' 123C 124C Lecture de la connectivite en mode descendant 125 call mmhphr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL, 126 & MED_DESCENDING,indexp2,indexf2,conn2,cret) 127 print *,cret 128 if (cret .ne. 0 ) then 129 print *,'Erreur lecture connectivite des polyedres' 130 call efexit(-1) 131 endif 132 print *,'Lecture de la connectivite des polyedres' 133 print *,'Connectivite descendante' 134C 135C Lecture des noms 136 call mmhear(fid,maa,MED_NO_DT,MED_NO_IT, 137 & MED_CELL,MED_POLYHEDRON,nom,cret) 138 print *,cret 139 if (cret .ne. 0 ) then 140 print *,'Erreur lecture noms des polyedres' 141 call efexit(-1) 142 endif 143 print *,'Lecture des noms' 144C 145C Lecture des numeros 146 call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL, 147 & MED_POLYHEDRON,num,cret) 148 print *,cret 149 if (cret .ne. 0 ) then 150 print *,'Erreur lecture des numeros des polyedres' 151 call efexit(-1) 152 endif 153 print *,'Lecture des numeros' 154C 155C Lecture des numeros de familles 156 call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL, 157 & MED_POLYHEDRON,fam,cret) 158 print *,cret 159 if (cret .ne. 0 ) then 160 print *,'Erreur lecture numeros de famille polyedres' 161 call efexit(-1) 162 endif 163 print *,'Lecture des numeros de famille' 164C 165C Affichage des resultats 166 print *,'Affichage des resultats' 167 do 20 j=1,npoly 168C 169 print *,'>> Maille polyhedre ',j 170 print *,'---- Connectivite nodale ---- : ' 171 nfaces = indexp(j+1) - indexp(j) 172C ind1 = indice dans "indexf" pour acceder aux 173C numeros des faces 174 ind1 = indexp(j) 175 do 30 k=1,nfaces 176C ind2 = indice dans "conn" pour acceder au premier noeud 177 ind2 = indexf(ind1+k-1) 178 nnoeuds = indexf(ind1+k) - indexf(ind1+k-1) 179 print *,' - Face ',k 180 do 40 l=1,nnoeuds 181 print *,' ',conn(ind2+l-1) 182 40 continue 183 30 continue 184 print *,'---- Connectivite descendante ---- : ' 185 nfaces = indexp2(j+1) - indexp2(j) 186C ind1 = indice dans "conn2" pour acceder aux faces 187 ind1 = indexp2(j) 188 do 50 k=1,nfaces 189 print *,' - Face ',k 190 print *,' => Numero : ',conn2(ind1+k-1) 191 print *,' => Type : ',indexf2(ind1+k-1) 192 50 continue 193 print *,'---- Nom ---- : ',nom(j) 194 print *,'---- Numero ----: ',num(j) 195 print *,'---- Numero de famille ---- : ',fam(j) 196C 197 20 continue 198C 199 10 continue 200C 201C Fermeture du fichier 202 call mficlo(fid,cret) 203 print *,cret 204 if (cret .ne. 0 ) then 205 print *,'Erreur fermeture du fichier' 206 call efexit(-1) 207 endif 208 print *,'Fermeture du fichier' 209C 210 end 211