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 : test6.f 21 C * 22 C * - Description : exemples d'ecriture d'elements dans un maillage MED 23 C * 24 C ****************************************************************************** 25 program test6 26 C 27 implicit none 28 include 'med.hf' 29 C 30 C 31 integer cret, fid 32 33 integer mdim,nse2,ntr3 34 parameter (nse2 = 5, ntr3 = 2, mdim = 2) 35 integer se2 (2*nse2) 36 character*16 nomse2(nse2) 37 integer numse2(nse2),nufase2(nse2) 38 39 integer tr3 (3*ntr3) 40 character*16 nomtr3(ntr3) 41 integer numtr3(ntr3), nufatr3(ntr3) 42 character*32 maa 43 44 data se2 / 1,2,1,3,2,4,3,4,2,3 / 45 data nomse2 /"se1","se2","se3","se4","se5" / 46 data numse2 / 1,2,3,4,5 /, nufase2 /-1,-1,0,-2,-3/ 47 data tr3 /1,2,-5,-5,3,-4 /, nomtr3 /"tr1","tr2"/, 48 & numtr3 /4,5/ 49 data nufatr3 /0,-1/, maa /"maa1"/ 50 51 C ** Ouverture du fichier ** 52 call efouvr(fid,'test6.med',MED_LECTURE_ECRITURE, cret) 53 print *,cret 54 if (cret .ne. 0 ) then 55 print *,'Erreur creation du fichier' 56 call efexit(-1) 57 endif 58 59 C ** Creation du maillage maa de dimension 2 ** 60 call efmaac(fid,maa,mdim,MED_NON_STRUCTURE, 61 & 'un maillage pour test6',cret) 62 print *,cret 63 if (cret .ne. 0 ) then 64 print *,'Erreur creation du maillage' 65 call efexit(-1) 66 endif 67 68 C ** Ecriture des connectivites des segments ** 69 call efcone(fid,maa,mdim,se2,MED_NO_INTERLACE, 70 & nse2,MED_ARETE, 71 & MED_SEG2,MED_DESC,cret ) 72 print *,cret 73 if (cret .ne. 0 ) then 74 print *,'Erreur ecriture de la connectivite' 75 call efexit(-1) 76 endif 77 78 C ** Ecriture (optionnelle) des noms des segments ** 79 call efnome(fid,maa,nomse2,nse2,MED_ARETE, 80 & MED_SEG2 ,cret) 81 print *,cret 82 if (cret .ne. 0 ) then 83 print *,'Erreur ecriture des noms' 84 call efexit(-1) 85 endif 86 87 C ** Ecriture (optionnelle) des numeros des segments ** 88 call efnume(fid,maa,numse2,nse2, 89 & MED_ARETE ,MED_SEG2,cret) 90 print *,cret 91 if (cret .ne. 0 ) then 92 print *,'Erreur ecriture des numeros' 93 call efexit(-1) 94 endif 95 96 C ** Ecriture des numeros des familles des segments ** 97 call effame(fid,maa,nufase2,nse2, 98 & MED_ARETE,MED_SEG2,cret) 99 print *,cret 100 if (cret .ne. 0 ) then 101 print *,'Erreur ecriture des numéros de famille' 102 call efexit(-1) 103 endif 104 105 C ** Ecriture des connectivites des triangles ** 106 call efcone(fid,maa,mdim,tr3,MED_NO_INTERLACE, 107 & ntr3,MED_MAILLE, 108 & MED_TRIA3,MED_DESC,cret ) 109 print *,cret 110 if (cret .ne. 0 ) then 111 print *,'Erreur ecriture de la connectivite' 112 call efexit(-1) 113 endif 114 115 C ** Ecriture (optionnelle) des noms des triangles ** 116 call efnome(fid,maa,nomtr3,ntr3,MED_MAILLE, 117 & MED_TRIA3,cret) 118 print *,cret 119 if (cret .ne. 0 ) then 120 print *,'Erreur ecriture des noms' 121 call efexit(-1) 122 endif 123 124 C ** Ecriture (optionnelle) des numeros des triangles ** 125 call efnume(fid,maa,numtr3,ntr3,MED_MAILLE, 126 & MED_TRIA3,cret) 127 print *,cret 128 if (cret .ne. 0 ) then 129 print *,'Erreur ecriture des numeros' 130 call efexit(-1) 131 endif 132 133 C ** Ecriture des numeros des familles des triangles ** 134 call effame(fid,maa,nufatr3,ntr3,MED_MAILLE, 135 & MED_TRIA3,cret) 136 print *,cret 137 if (cret .ne. 0 ) then 138 print *,'Erreur ecriture des numeros de famille' 139 call efexit(-1) 140 endif 141 142 C ** Fermeture du fichier ** 143 call efferm (fid,cret) 144 print *,cret 145 if (cret .ne. 0 ) then 146 print *,'Erreur a la fermeture du fichier' 147 call efexit(-1) 148 endif 149 C 150 end