      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