1 C************************************************************************* 2 C COPYRIGHT (C) 1999 - 2007 EDF R&D, CEA/DEN 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 : test25.f 21 C * 22 C * - Description : ecriture de mailles MED_POLYEDRE dans un maillage MED 23 C * 24 C ****************************************************************************** 25 program test25 26 C 27 implicit none 28 include 'med.hf' 29 C 30 integer cret, fid,mdim 31 parameter (mdim = 3) 32 character*32 maa 33 integer n 34 parameter (n=2) 35 C Connectivite nodale 36 integer np,nf 37 parameter (nf=9,np=3) 38 integer indexp(np),indexf(nf) 39 integer conn(24) 40 C Connectivite descendante 41 integer np2,nf2 42 parameter (nf2=8,np2=3) 43 integer indexp2(np2),indexf2(nf2) 44 integer conn2(nf2) 45 character*16 nom(n) 46 integer num(n),fam(n) 47 C 48 data indexp / 1,5,9 / 49 data indexf / 1,4,7,10,13,16,19,22,25 / 50 data conn / 1,2,3,4,5,6,7,8,9,10,11,12,13,14, 51 & 15,16,17,18,19,20,21,22,23,24 / 52 data indexp2 / 1,5,9 / 53 data indexf2 / MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3, 54 & MED_TRIA3,MED_TRIA3,MED_TRIA3,MED_TRIA3 / 55 data conn2 / 1,2,3,4,5,6,7,8 / 56 data nom / "poly1", "poly2"/ 57 data num / 1,2 /, fam / 0,-1 / 58 data maa /"maa1"/ 59 60 C ** Creation du fichier test25.med ** 61 call efouvr(fid,'test25.med',MED_LECTURE_ECRITURE, cret) 62 print *,cret 63 if (cret .ne. 0 ) then 64 print *,'Erreur creation du fichier' 65 call efexit(-1) 66 endif 67 print *,'Creation du fichier test25.med' 68 69 C ** Creation du maillage ** 70 call efmaac(fid,maa,mdim,MED_NON_STRUCTURE, 71 & 'un maillage pour test25',cret) 72 if (cret .ne. 0 ) then 73 print *,'Erreur creation du maillage' 74 call efexit(-1) 75 endif 76 print *,cret 77 print *,'Creation du maillage' 78 79 C ** Ecriture des connectivites des mailles polyedres en mode nodal ** 80 call efpece(fid,maa,indexp,np,indexf,nf,conn,MED_NOD,cret) 81 print *,cret 82 if (cret .ne. 0 ) then 83 print *,'Erreur ecriture connectivite des polyedres' 84 call efexit(-1) 85 endif 86 print *,'Ecriture des connectivites des mailles 87 & de type MED_POLYEDRE' 88 print *,'Description nodale' 89 90 C ** Ecriture des connectivites des mailles polyedres en mode descendant ** 91 call efpece(fid,maa,indexp2,np2,indexf2,nf2,conn2,MED_DESC,cret) 92 print *,cret 93 if (cret .ne. 0 ) then 94 print *,'Erreur ecriture connectivite des polyedres' 95 call efexit(-1) 96 endif 97 print *,'Ecriture des connectivites des mailles 98 & de type MED_POLYEDRE' 99 print *,'Description descendante' 100 101 C ** Ecriture des noms des mailles polyedres ** 102 call efnome(fid,maa,nom,n,MED_MAILLE,MED_POLYEDRE, 103 & cret) 104 print *,cret 105 if (cret .ne. 0 ) then 106 print *,'Erreur ecriture noms des polyedres' 107 call efexit(-1) 108 endif 109 print *,'Ecriture des noms des polyedress' 110 111 C ** Ecriture des numeros des mailles polyedres ** 112 call efnume(fid,maa,num,n,MED_MAILLE,MED_POLYEDRE, 113 & cret) 114 print *,cret 115 if (cret .ne. 0 ) then 116 print *,'Erreur ecriture numeros des polyedres' 117 call efexit(-1) 118 endif 119 print *,'Ecriture des numeros des polyedres' 120 121 C ** Ecriture des numeros des familles des segments ** 122 call effame(fid,maa,fam,n, 123 & MED_MAILLE,MED_POLYEDRE,cret) 124 print *,cret 125 if (cret .ne. 0 ) then 126 print *,'Erreur ecriture numeros de familles polyedres' 127 call efexit(-1) 128 endif 129 print *,'Ecriture des numeros de familles des polyedres' 130 131 C ** Fermeture du fichier ** 132 call efferm (fid,cret) 133 print *,cret 134 if (cret .ne. 0 ) then 135 print *,'Erreur fermeture du fichier' 136 call efexit(-1) 137 endif 138 print *,'Fermeture du fichier' 139 C 140 end