1 !************************************************************************* 2 ! COPYRIGHT (C) 1999 - 2003 EDF R&D 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 : test15.f90 21 ! * 22 ! * - Description : lecture des noeuds d'un maillage MED. 23 ! * a l'aide des routines de niveau 2 24 ! * - equivalent a test5.f90 25 ! * 26 ! ****************************************************************************** 27 28 program test15 29 30 implicit none 31 include 'med.hf' 32 ! 33 ! 34 integer ret,cret, fid; 35 ! ** la dimension du maillage ** 36 integer mdim 37 ! ** nom du maillage de longueur maxi MED_TAILLE_NOM ** 38 character*32 maa 39 character*200 desc 40 ! ** le nombre de noeuds ** 41 integer :: nnoe = 0 42 ! ** table des coordonnees ** 43 real*8, allocatable, dimension(:) :: coo 44 ! ** tables des noms et des unites des coordonnees 45 ! profil : (dimension) ** 46 character*16 nomcoo(2) 47 character*16 unicoo(2) 48 ! ** tables des noms, numeros, numeros de familles des noeuds 49 ! autant d'elements que de noeuds - les noms ont pout longueur 50 ! MED_TAILLE_PNOM ** 51 character*16, allocatable, dimension(:) :: nomnoe 52 integer, allocatable, dimension(:) :: numnoe,nufano 53 integer rep 54 logical inonoe,inunoe 55 character*16 str 56 integer i 57 character*255 argc 58 integer type 59 60 print *,"Indiquez le fichier med a decrire : " 61 read(*,*) argc 62 63 ! ** Ouverture du fichier ** 64 call efouvr(fid,argc,MED_LECTURE, cret) 65 print *,cret 66 67 68 ! ** Lecture des infos concernant le premier maillage ** 69 if (cret.eq.0) then 70 call efmaai(fid,1,maa,mdim,type,desc,cret) 71 print *,"Maillage de nom : ",maa," et de dimension : ",mdim 72 endif 73 print *,cret 74 75 ! ** Lecture du nombre de noeud ** 76 if (cret.eq.0) then 77 call efnema(fid,maa,MED_COOR,MED_NOEUD,0,0,nnoe,cret) 78 print *,"Nombre de noeuds : ",nnoe 79 endif 80 print *,cret 81 82 ! ** Allocations memoires ** 83 ! ** table des coordonnees 84 ! ** profil : (dimension * nombre de noeuds ) ** 85 allocate (coo(nnoe*mdim),STAT=ret) 86 ! ** table des des numeros, des numeros de familles des noeuds 87 ! profil : (nombre de noeuds) ** 88 allocate (numnoe(nnoe),nufano(nnoe),STAT=ret) 89 ! ** table des noms des noeuds 90 ! profil : (nnoe*MED_TAILLE_PNOM+1) ** 91 allocate (nomnoe(nnoe),STAT=ret) 92 93 ! ** Lecture des noeuds : 94 ! - Coordonnees 95 ! - Noms (optionnel dans un fichier MED) 96 ! - Numeros (optionnel dans un fichier MED) 97 ! - Numeros de familles ** 98 if (cret.eq.0) then 99 call efnoel(fid,maa,mdim,coo,MED_FULL_INTERLACE,rep,nomcoo,unicoo, & 100 & nomnoe,inonoe,numnoe,inunoe,nufano,nnoe,cret) 101 endif 102 103 ! ** Affichage des resulats ** 104 if (cret.eq.0) then 105 print *,"Type de repere : ",rep 106 print *,"Nom des coordonnees : ",nomcoo 107 108 print *,"Unites des coordonnees : ",unicoo 109 110 print *,"Coordonnees des noeuds : ",coo 111 112 if (inonoe) then 113 print *,"Noms des noeuds : |",nomnoe,"|" 114 endif 115 116 if (inunoe) then 117 print *,"Numeros des noeuds : ",numnoe 118 endif 119 120 print *,"Numeros des familles des noeuds : ",nufano 121 endif 122 123 ! ** Liberation memoire ** 124 deallocate(coo,nomnoe,numnoe,nufano) 125 126 ! ** Fermeture du fichier ** 127 call efferm (fid,cret) 128 print *,cret 129 130 end program test15 131