1!* This file is part of MED. 2!* 3!* COPYRIGHT (C) 1999 - 2019 EDF R&D, CEA/DEN 4!* MED is free software: you can redistribute it and/or modify 5!* it under the terms of the GNU Lesser General Public License as published by 6!* the Free Software Foundation, either version 3 of the License, or 7!* (at your option) any later version. 8!* 9!* MED is distributed in the hope that it will be useful, 10!* but WITHOUT ANY WARRANTY; without even the implied warranty of 11!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12!* GNU Lesser General Public License for more details. 13!* 14!* You should have received a copy of the GNU Lesser General Public License 15!* along with MED. If not, see <http://www.gnu.org/licenses/>. 16!* 17 18! ****************************************************************************** 19! * - Nom du fichier : test7.f90 20! * 21! * - Description : lecture des elements du maillage MED ecrits par test6 22! * 23! ****************************************************************************** 24 program test7 25 26 implicit none 27 include 'med.hf90' 28! 29! 30 integer*8 fid 31 integer cret, ret 32 33 integer nse2 34 integer, allocatable, dimension (:) :: se2,se21 35 character*16, allocatable, dimension (:) :: nomse2 36 integer, allocatable, dimension (:) :: numse2,nufase2 37 38 integer ntr3 39 integer, allocatable, dimension (:) :: tr3 40 character*16, allocatable, dimension (:) :: nomtr3 41 integer, allocatable, dimension (:) :: numtr3,nufatr3 42 43! ** nom du maillage de longueur maxi MED_TAILLE_NOM ** 44 character*64 :: maa 45 character*200 :: desc 46 integer :: mdim,edim,nstep,stype,atype 47 logical inoele,inuele 48 integer, parameter :: profil (2) = (/ 2,3 /) 49 integer type 50 integer tse2,ttr3, i 51 character*16 nomcoo(2) 52 character*16 unicoo(2) 53 character*16 dtunit 54 integer :: chgt,tsf 55 integer flta(1) 56 integer*8 flt(1) 57 58! ** Ouverture du fichier test6.med en lecture seule ** 59 call mfiope(fid,'test6.med',MED_ACC_RDONLY, cret) 60 print *,cret 61 62! ** Lecture des infos concernant le premier maillage ** 63 if (cret.eq.0) then 64 call mmhmii(fid,1,maa,edim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,cret) 65 print *,"Maillage de nom : ",maa," et de dimension :", mdim 66 endif 67 if (cret.ne.0) then 68 call efexit(-1) 69 endif 70! ** Combien de segments et de triangles ** 71 if (cret.eq.0) then 72 nse2 = 0 73 call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_CONNECTIVITY,MED_DESCENDING,chgt,tsf,nse2,cret) 74 endif 75 if (cret.ne.0) then 76 call efexit(-1) 77 endif 78 79 if (cret.eq.0) then 80 ntr3 = 0 81 call mmhnme(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,MED_CONNECTIVITY,MED_DESCENDING,chgt,tsf,ntr3,cret) 82 endif 83 if (cret.ne.0) then 84 call efexit(-1) 85 endif 86 87 if (cret.eq.0) then 88 print *,"Nombre de MED_SEG2 : ",nse2," - nombre de MED_TRIA3 : ",ntr3 89 endif 90 91! ** Allocations memoire ** 92 tse2 = 2 93 allocate (se2(tse2*nse2),se21(tse2*nse2),nomse2(nse2),numse2(nse2), nufase2(nse2),STAT=ret ) 94 se2(:)=0; se21(:)=0 95! print *,ret 96 97 ttr3 = 3 98 allocate (tr3(ntr3*ttr3), nomtr3(ntr3), numtr3(ntr3),nufatr3(ntr3),STAT=ret ) 99 tr3(:)=0 100! print *,ret 101 102 103! ** Lecture de la connectivite des segments ** 104 if (cret.eq.0) then 105 call mmhcyr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING,MED_FULL_INTERLACE,se2,cret) 106 endif 107 if (cret.ne.0) then 108 call efexit(-1) 109 endif 110 print *,se2 111 112! ** Lecture de de la composante 2 de la connectivite des segments ** 113! ** On cree un filtre associe 114 if (cret .eq. 0) then 115 call mfrall(1,flt,cret) 116 endif 117 if (cret.ne.0) then 118 call efexit(-1) 119 endif 120 121! ** on initialise le filtre pour lire uniquement la deuxième composante. 122 if (cret .eq. 0) then 123 call mfrcre(fid,nse2,1,edim,2,MED_FULL_INTERLACE,MED_GLOBAL_STMODE, & 124 MED_NO_PROFILE,MED_UNDEF_SIZE,flta,flt(1),cret) 125 endif 126 if (cret.ne.0) then 127 call efexit(-1) 128 endif 129 130! ** Lecture des composantes n°2 des segments 131 if (cret.eq.0) then 132 call mmhyar(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,MED_DESCENDING, & 133 flt(1),se21,cret) 134 endif 135 if (cret.ne.0) then 136 call efexit(-1) 137 endif 138 print *,se21 139 140! ** On desalloue le filtre 141 if (cret .eq. 0) then 142 call mfrdea(1,flt,cret) 143 endif 144 if (cret.ne.0) then 145 call efexit(-1) 146 endif 147 148! ** Lecture (optionnelle) des noms des segments ** 149 if (cret.eq.0) then 150 call mmhear(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,nomse2,cret) 151 endif 152 153 if (ret <0) then 154 inoele = .FALSE. 155 else 156 inoele = .TRUE. 157 endif 158 159! ** Lecture (optionnelle) des numeros des segments ** 160 if (cret.eq.0) then 161 call mmhenr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,numse2,cret) 162 endif 163 164 if (ret <0) then 165 inuele = .FALSE. 166 else 167 inuele = .TRUE. 168 endif 169 170! ** Lecture des numeros des familles des segments ** 171 if (cret.eq.0) then 172 call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_DESCENDING_EDGE,MED_SEG2,nufase2,cret) 173 endif 174 if (cret.ne.0) then 175 call efexit(-1) 176 endif 177 178! ** Lecture de la connectivite des triangles sans profil ** 179 if (cret.eq.0) then 180 call mmhcyr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,MED_DESCENDING,MED_NO_INTERLACE,tr3,cret) 181 endif 182 if (cret.ne.0) then 183 call efexit(-1) 184 endif 185 186! ** Lecture (optionnelle) des noms des triangles ** 187 if (cret.eq.0) then 188 call mmhear(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,nomtr3,cret) 189 endif 190 191 if (ret <0) then 192 inoele = .FALSE. 193 else 194 inoele = .TRUE. 195 endif 196 print *,cret 197 198! ** Lecture (optionnelle) des numeros des segments ** 199 if (cret.eq.0) then 200 call mmhenr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,numtr3,cret) 201 endif 202 203 if (ret <0) then 204 inuele = .FALSE. 205 else 206 inuele = .TRUE. 207 endif 208 print *,cret 209 210! ** Lecture des numeros des familles des segments ** 211 if (cret.eq.0) then 212 call mmhfnr(fid,maa,MED_NO_DT,MED_NO_IT,MED_CELL,MED_TRIA3,nufatr3,cret) 213 endif 214 print *,cret 215 216! ** Fermeture du fichier ** 217 call mficlo(fid,cret) 218 if (cret.ne.0) then 219 call efexit(-1) 220 endif 221 222! ** Affichage des resulats ** 223 if (cret.eq.0) then 224 225 print *,"Connectivite des segments : " 226 print *, se2 227 228 if (inoele) then 229 print *,"Noms des segments :" 230 print *,nomse2 231 endif 232 233 if (inuele) then 234 print *,"Numeros des segments :" 235 print *,numse2 236 endif 237 238 print *,"Numeros des familles des segments :" 239 print *,nufase2 240 241 print *,"Connectivite des triangles :" 242 print *,tr3 243 244 if (inoele) then 245 print *,"Noms des triangles :" 246 print *,nomtr3 247 endif 248 249 if (inuele) then 250 print *,"Numeros des triangles :" 251 print *,numtr3 252 endif 253 254 print *,"Numeros des familles des triangles :" 255 print *,nufatr3 256 257 endif 258 259! ** Nettoyage memoire ** 260 deallocate (se2,se21,nomse2,numse2,nufase2,tr3,nomtr3,numtr3,nufatr3) 261 262! ** Code retour 263 call efexit(cret) 264 265 end program test7 266 267