1 C************************************************************************* 2 C COPYRIGHT (C) 1999 - 2003 EDF R&D 3 C THIS LIBRARY IS FREE SOFTWARE; YOU CAN REDISTRIBUTE IT AND/OR MODIFY 4 C IT UNDER THE TERMS OF THE GNU LESSER GENERAL PUBLIC LICENSE 5 C AS PUBLISHED BY THE FREE SOFTWARE FOUNDATION; 6 C EITHER VERSION 2.1 OF THE LICENSE, OR (AT YOUR OPTION) ANY LATER VERSION. 7 C 8 C THIS LIBRARY IS DISTRIBUTED IN THE HOPE THAT IT WILL BE USEFUL, BUT 9 C WITHOUT ANY WARRANTY; WITHOUT EVEN THE IMPLIED WARRANTY OF 10 C MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. SEE THE GNU 11 C LESSER GENERAL PUBLIC LICENSE FOR MORE DETAILS. 12 C 13 C YOU SHOULD HAVE RECEIVED A COPY OF THE GNU LESSER GENERAL PUBLIC LICENSE 14 C ALONG WITH THIS LIBRARY; IF NOT, WRITE TO THE FREE SOFTWARE FOUNDATION, 15 C INC., 59 TEMPLE PLACE, SUITE 330, BOSTON, MA 02111-1307 USA 16 C 17 C************************************************************************** 18 19 C ****************************************************************************** 20 C * - Nom du fichier : test8.f 21 C * 22 C * - Description : exemple d'ecriture des familles d'un maillage MED 23 C * 24 C ***************************************************************************** 25 program test8 26 C 27 implicit none 28 include 'med.hf' 29 C 30 integer cret, fid 31 32 character*32 maa 33 integer mdim 34 character*32 nomfam 35 integer numfam 36 character*200 attdes 37 integer natt, attide, attval 38 integer ngro 39 character*80 gro 40 integer nfame, nfamn 41 character*16 str 42 43 parameter ( mdim = 2, nfame = 3, nfamn = 2 ) 44 data maa /"maa1"/ 45 46 C ** Creation du fichier test8.med ** 47 call efouvr(fid,'test8.med',MED_CREATION, cret) 48 print *,cret 49 50 C ** Creation du maillage maa de dimension 2 ** 51 if (cret .eq. 0) then 52 call efmaac(fid,maa,mdim,MED_NON_STRUCTURE, 53 & 'un maillage pour test8',cret) 54 endif 55 print *,cret 56 57 C ** Ecriture des familles ** 58 C ** Conventions : 59 C - Toujours creer une famille de numero 0 ne comportant aucun attribut 60 C ni groupe (famille de reference pour les noeuds ou les elements 61 C qui ne sont rattaches a aucun groupe ni attribut) 62 C - Les numeros de familles de noeuds sont > 0 63 C - Les numeros de familles des elements sont < 0 64 C - Rien d imposer sur les noms de familles 65 C ** ** 66 67 C ** Creation de la famille 0 68 if (cret .eq. 0) then 69 numfam = 0 70 nomfam="FAMILLE_0" 71 call effamc(fid,maa,nomfam,numfam,attide,attval,attdes, 72 & 0,gro,0,cret) 73 endif 74 print *,cret 75 76 C ** Creation pour correspondre aux cas tests precedents, 3 familles * 77 C ** d elements (-1,-2,-3) et deux familles de noeuds (1,2) * 78 if (cret .eq. 0) then 79 do numfam=-1,-3,-1 80 if (cret .eq. 0) then 81 write(str,'(I1.0)') (-numfam) 82 nomfam = "FAMILLE_ELEMENT_"//str 83 attide = 1 84 attval = numfam*100 85 natt = 1 86 attdes="description attribut" 87 gro="groupe1" 88 ngro = 1 89 print *, nomfam," - ",numfam," - ",attide," - ", 90 & attval," - ",ngro 91 92 call effamc(fid,maa,nomfam,numfam,attide,attval,attdes, 93 & natt,gro,ngro,cret) 94 print *,"MEDfamCr : ",cret 95 endif 96 end do 97 end if 98 99 if (cret .eq. 0) then 100 do numfam=1,nfamn 101 if (cret .eq. 0) then 102 write(str,'(I1.0)') numfam 103 nomfam = "FAMILLE_NOEUD_"//str 104 attide = 1 105 attval = numfam*100 106 natt = 1 107 attdes="description attribut" 108 gro="groupe1" 109 ngro = 1 110 print *, nomfam," - ",numfam," - ",attide," - ", 111 & attval," - ",ngro 112 call effamc(fid,maa,nomfam,numfam,attide,attval,attdes, 113 & natt,gro,ngro,cret) 114 print *,"MEDfamCr : ",cret 115 116 endif 117 end do 118 end if 119 120 121 C ** Fermeture du fichier * 122 call efferm (fid,cret) 123 print *,cret 124 125 126 end 127 128 129 130 131 132