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 : test13.f90 21 ! * 22 ! * - Description : lecture des equivalences dans un maillage MED. 23 ! * 24 ! ****************************************************************************** 25 26 program test13 27 28 implicit none 29 include 'med.hf' 30 ! 31 ! 32 integer ret,cret,fid 33 character*32 maa 34 integer mdim,nequ,ncor 35 integer, allocatable, dimension(:) :: cor 36 character*32 equ 37 character*200 des 38 integer i,j,k 39 character*255 argc 40 integer, parameter :: MED_NBR_MAILLE_EQU = 8 41 integer,parameter :: typmai(MED_NBR_MAILLE_EQU) = (/ MED_POINT1,MED_SEG2, & 42 & MED_SEG3,MED_TRIA3, & 43 & MED_TRIA6,MED_QUAD4, & 44 & MED_QUAD8,MED_POLYGONE/) 45 46 integer,parameter :: typfac(MED_NBR_GEOMETRIE_FACE+1) = (/MED_TRIA3,MED_TRIA6, & 47 & MED_QUAD4,MED_QUAD8, MED_POLYGONE/) 48 integer,parameter ::typare(MED_NBR_GEOMETRIE_ARETE) = (/MED_SEG2,MED_SEG3/) 49 character*200 desc 50 integer type 51 52 print *,"Indiquez le fichier med a decrire : " 53 !!read(*,*) argc 54 argc = "test12.med" 55 56 ! ** Ouverture du fichier en lecture seule ** 57 call efouvr(fid,argc,MED_LECTURE, cret) 58 print *,cret 59 60 61 ! ** Lecture des infos sur le premier maillage ** 62 if (cret.eq.0) then 63 call efmaai(fid,1,maa,mdim,type,desc,cret) 64 print *,"Maillage de nom : ",maa," et de dimension : ", mdim 65 endif 66 print *,cret 67 68 69 ! ** Lecture du nombre d'equivalence ** 70 if (cret.eq.0) then 71 call efnequ(fid,maa,nequ,cret) 72 if (cret.eq.0) then 73 print *,"Nombre d'equivalences : ",nequ 74 endif 75 endif 76 77 !** Lecture de toutes les equivalences ** 78 if (cret.eq.0) then 79 do i=1,nequ 80 print *,"Equivalence numero : ",i 81 !** Lecture des infos sur l'equivalence ** 82 if (cret.eq.0) then 83 call efequi(fid,maa,i,equ,des,cret) 84 endif 85 print *,cret 86 if (cret.eq.0) then 87 print *,"Nom de l'equivalence : ",equ 88 print *,"Description de l'equivalence : ",des 89 endif 90 91 !** Lecture des correspondances sur les differents types d'entites ** 92 if (cret.eq.0) then 93 !** Les noeuds ** 94 call efncor(fid,maa,equ,MED_NOEUD,0,ncor,cret) 95 print *,"Il y a ",ncor," correspondances sur les noeuds " 96 if (ncor > 0) then 97 allocate(cor(ncor*2),STAT=ret) 98 call efequl(fid,maa,equ,cor,ncor,MED_NOEUD,0,cret) 99 do j=0,(ncor-1) 100 print *,"Correspondance ",j+1," : ",cor(2*j+1)," et ",cor(2*j+2) 101 end do 102 deallocate(cor) 103 end if 104 105 !** Les mailles : on ne prend pas en compte les mailles 3D ** 106 107 do j=1,MED_NBR_MAILLE_EQU 108 call efncor(fid,maa,equ,MED_MAILLE,typmai(j),ncor,cret) 109 print *,"Il y a ",ncor," correspondances sur les mailles ",typmai(j) 110 if (ncor > 0 ) then 111 allocate(cor(2*ncor),STAT=ret) 112 call efequl(fid,maa,equ,cor,ncor,MED_MAILLE,typmai(j),cret) 113 do k=0,(ncor-1) 114 print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2) 115 end do 116 deallocate(cor) 117 endif 118 end do 119 120 ! ** Les faces ** 121 do j=1,MED_NBR_GEOMETRIE_FACE+1 122 call efncor(fid,maa,equ,MED_FACE,typfac(j),ncor,cret) 123 print *,"Il y a ",ncor," correspondances sur les faces ",typfac(j) 124 if (ncor > 0 ) then 125 allocate(cor(2*ncor),STAT=ret) 126 call efequl(fid,maa,equ,cor,ncor,MED_FACE,typfac(j),cret) 127 do k=0,(ncor-1) 128 print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2) 129 end do 130 deallocate(cor) 131 endif 132 end do 133 134 ! ** Les aretes ** 135 do j=1,MED_NBR_GEOMETRIE_ARETE 136 call efncor(fid,maa,equ,MED_ARETE,typare(j),ncor,cret) 137 print *,"Il y a ",ncor," correspondances sur les aretes ",typare(j) 138 if (ncor > 0 ) then 139 allocate(cor(2*ncor),STAT=ret) 140 call efequl(fid,maa,equ,cor,ncor,MED_ARETE,typare(j),cret) 141 do k=0,(ncor-1) 142 print *,"Correspondance ",k+1," : ",cor(2*k+1)," et ",cor(2*k+2) 143 end do 144 deallocate(cor) 145 endif 146 end do 147 148 end if 149 end do 150 end if 151 152 ! ** Fermeture du fichier ** 153 call efferm (fid,cret) 154 print *,cret 155 156 ! ** Code retour 157 call efexit(cret) 158 159 end program test13 160 161 162 163 164