1 !************************************************************************* 2 ! COPYRIGHT (C) 1999 - 2007 EDF R&D, CEA/DEN 3 ! THIS LIBRARY IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR MODIFY 4 ! IT UNDER THE TERMS OF THE GNU LESSER GENERAL PUBLIC LICENSE 5 ! AS PUBLISHED BY THE FREE SOFTWARE FOUNDATION; 6 ! EITHER VERSION 2.1 OF THE LICENSE, OR (AT YOUR OPTION) ANY LATER VERSION. 7 ! 8 ! THIS LIBRARY IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL, BUT 9 ! WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF 10 ! MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. SEE THE GNU 11 ! LESSER GENERAL PUBLIC LICENSE FOR MORE DETAILS. 12 ! 13 ! YOU SHOULD HAVE RECEIVED A COPY OF THE GNU LESSER GENERAL PUBLIC LICENSE 14 ! ALONG WITH THIS LIBRARY; IF NOT, WRITE TO THE FREE SOFTWARE FOUNDATION, 15 ! INC., 59 TEMPLE PLACE, SUITE 330, BOSTON, MA 02111-1307 USA 16 ! 17 !************************************************************************** 18 19 ! ****************************************************************************** 20 ! * - Nom du fichier : test7.f90 21 ! * 22 ! * - Description : lecture des elements du maillage MED ecrits par test6 23 ! * 24 ! ****************************************************************************** 25 program test7 26 27 implicit none 28 include 'med.hf' 29 ! 30 ! 31 integer cret, ret, fid 32 33 integer nse2 34 integer, allocatable, dimension (:) :: se2 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*32 :: maa = "maa1" 45 character*200 :: desc 46 integer :: mdim 47 logical inoele,inuele 48 integer, parameter :: profil (2) = (/ 2,3 /) 49 integer type 50 integer tse2,ttr3, i 51 52 ! ** Ouverture du fichier test6.med en lecture seule ** 53 call efouvr(fid,'test6.med',MED_LECTURE, cret) 54 print *,cret 55 56 ! ** Lecture des infos concernant le premier maillage ** 57 if (cret.eq.0) then 58 call efmaai(fid,1,maa,mdim,type,desc,cret) 59 print *,"Maillage de nom : ",maa," et de dimension :", mdim 60 endif 61 print *,cret 62 63 ! ** Combien de segments et de triangles ** 64 if (cret.eq.0) then 65 nse2 = 0 66 call efnema(fid,maa,MED_CONN,MED_ARETE,MED_SEG2,MED_DESC, & 67 & nse2,cret) 68 endif 69 print *,cret 70 71 if (cret.eq.0) then 72 ntr3 = 0 73 call efnema(fid,maa,MED_CONN,MED_MAILLE,MED_TRIA3,MED_DESC, & 74 & ntr3,cret) 75 endif 76 print *,cret 77 78 if (cret.eq.0) then 79 print *,"Nombre de MED_SEG2 : ",nse2," - nombre de MED_TRIA3 : ",ntr3 80 endif 81 82 ! ** Allocations memoire ** 83 tse2 = 2 84 allocate ( se2(tse2*nse2), nomse2(nse2),numse2(nse2), nufase2(nse2),STAT=ret ) 85 ! print *,ret 86 87 ttr3 = 3 88 allocate ( tr3(ntr3*ttr3), nomtr3(ntr3), numtr3(ntr3),nufatr3(ntr3),STAT=ret ) 89 ! print *,ret 90 91 92 ! ** Lecture de la connectivite des segments avec profil ** 93 if (cret.eq.0) then 94 call efconl(fid,maa,mdim,se2,MED_NO_INTERLACE,profil,2,MED_ARETE, & 95 & MED_SEG2,MED_DESC,cret) 96 endif 97 print *,cret 98 print *,se2 99 100 ! ** Lecture (optionnelle) des noms des segments ** 101 if (cret.eq.0) then 102 call efnoml(fid,maa,nomse2,nse2,MED_ARETE, & 103 & MED_SEG2,ret) 104 endif 105 106 if (ret <0) then 107 inoele = .FALSE. 108 else 109 inoele = .TRUE. 110 endif 111 112 ! ** Lecture (optionnelle) des numeros des segments ** 113 if (cret.eq.0) then 114 call efnuml(fid,maa,numse2,nse2,MED_ARETE,MED_SEG2,ret) 115 endif 116 117 if (ret <0) then 118 inuele = .FALSE. 119 else 120 inuele = .TRUE. 121 endif 122 123 ! ** Lecture des numeros des familles des segments ** 124 if (cret.eq.0) then 125 call effaml(fid,maa,nufase2,nse2,MED_ARETE,MED_SEG2,cret) 126 endif 127 print *,cret 128 129 ! ** Lecture de la connectivite des triangles sans profil ** 130 if (cret.eq.0) then 131 call efconl(fid,maa,mdim,tr3,MED_NO_INTERLACE,profil,0,MED_MAILLE, & 132 & MED_TRIA3,MED_DESC,cret) 133 endif 134 print *,cret 135 136 ! ** Lecture (optionnelle) des noms des triangles ** 137 if (cret.eq.0) then 138 call efnoml(fid,maa,nomtr3,ntr3,MED_MAILLE, & 139 & MED_TRIA3,ret) 140 endif 141 142 if (ret <0) then 143 inoele = .FALSE. 144 else 145 inoele = .TRUE. 146 endif 147 print *,cret 148 149 ! ** Lecture (optionnelle) des numeros des segments ** 150 if (cret.eq.0) then 151 call efnuml(fid,maa,numtr3,ntr3,MED_MAILLE,MED_TRIA3,ret) 152 endif 153 154 if (ret <0) then 155 inuele = .FALSE. 156 else 157 inuele = .TRUE. 158 endif 159 print *,cret 160 161 ! ** Lecture des numeros des familles des segments ** 162 if (cret.eq.0) then 163 call effaml(fid,maa,nufatr3,ntr3,MED_MAILLE,MED_TRIA3,cret) 164 endif 165 print *,cret 166 167 ! ** Fermeture du fichier ** 168 call efferm (fid,cret) 169 print *,cret 170 171 ! ** Affichage des resulats ** 172 if (cret.eq.0) then 173 174 print *,"Connectivite des segments : " 175 print *, se2 176 177 if (inoele) then 178 print *,"Noms des segments :" 179 print *,nomse2 180 endif 181 182 if (inuele) then 183 print *,"Numeros des segments :" 184 print *,numse2 185 endif 186 187 print *,"Numeros des familles des segments :" 188 print *,nufase2 189 190 print *,"Connectivite des triangles :" 191 print *,tr3 192 193 if (inoele) then 194 print *,"Noms des triangles :" 195 print *,nomtr3 196 endif 197 198 if (inuele) then 199 print *,"Numeros des triangles :" 200 print *,numtr3 201 endif 202 203 print *,"Numeros des familles des triangles :" 204 print *,nufatr3 205 206 endif 207 208 ! ** Nettoyage memoire ** 209 deallocate (se2,nomse2,numse2,nufase2,tr3,nomtr3,numtr3,nufatr3) 210 211 ! ** Code retour 212 call efexit(cret) 213 214 end program test7 215