      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