1!*  This file is part of MED.
2!*
3!*  COPYRIGHT (C) 1999 - 2019  EDF R&D, CEA/DEN
4!*  MED is free software: you can redistribute it and/or modify
5!*  it under the terms of the GNU Lesser General Public License as published by
6!*  the Free Software Foundation, either version 3 of the License, or
7!*  (at your option) any later version.
8!*
9!*  MED is distributed in the hope that it will be useful,
10!*  but WITHOUT ANY WARRANTY; without even the implied warranty of
11!*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12!*  GNU Lesser General Public License for more details.
13!*
14!*  You should have received a copy of the GNU Lesser General Public License
15!*  along with MED.  If not, see <http://www.gnu.org/licenses/>.
16!*
17
18
19! ******************************************************************************
20! * - Nom du fichier : test11.f90
21! *
22! * - Description : lecture de champs de resultats MED
23! *
24! *****************************************************************************
25
26program test11
27
28  implicit none
29  include 'med.hf90'
30
31
32  integer*8     fid
33  integer       cret,ret,lret,retmem
34  integer       USER_INTERLACE,USER_MODE
35  character*64  :: maa,nomcha,pflname,nomlien,locname
36  character*200 desc
37  character*255 argc
38  character*16, allocatable, dimension(:) :: comp,unit
39  character*16  dtunit
40  integer       mdim,ncomp,ncha,npro,nln,pflsize,nval
41  integer,      allocatable, dimension(:) :: pflval
42  integer       ngauss,nloc
43  integer       t1,t2,t3,typcha,type,type_geo
44  real*8,       allocatable, dimension(:) :: refcoo, gscoo, wg
45  character*255 lien
46  integer       i,j
47  integer       getFieldsOn
48  integer nstep, stype, atype,sdim
49  character*16 nomcoo(3)
50  character*16 unicoo(3)
51  integer lmesh, ncst
52  character*64  :: giname, isname
53  integer nsmc, sgtype
54
55  parameter (USER_INTERLACE = MED_FULL_INTERLACE)
56  parameter (USER_MODE = MED_COMPACT_PFLMODE)
57
58  cret=0;ret=0;lret=0;retmem=0
59  print *,"Indiquez le fichier med a decrire : "
60  !!read(*,'(A)') argc
61  argc="test10.med"
62
63  !  ** ouverture du fichier **
64  call mfiope(fid,argc,MED_ACC_RDONLY, ret)
65  if (ret .ne. 0) call efexit(-1)
66
67  !  ** info sur le premier maillage **
68  if (ret.eq.0) then
69     call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
70  endif
71  if (ret.ne.0) then
72     print *, "Erreur a la lecture des informations sur le maillage : ", &
73          & maa,mdim,type,desc
74     call efexit(-1)
75  endif
76
77  write (*,'(/A,A,A,I1)') "Maillage de nom |",TRIM(maa),"| et de dimension ",mdim
78
79  !  ** combien de champs dans le fichier **
80  call mfdnfd(fid,ncha,ret)
81  if (ret.ne.0) then
82     print *, "Impossible de lire le nombre de champs : ",ncha
83     call efexit(-1)
84  endif
85
86  write (*,'(A,I1/)') "Nombre de champs : ",ncha
87
88
89  ! ** lecture de tous les champs associes a <maa> **
90  do i=1,ncha
91     lret = 0
92     write(*,'(A,I5)') "- Champ numero : ",i
93
94     ! ** combien de composantes **
95     call mfdnfc(fid,i,ncomp,ret)
96     !   print *,ncomp,ret
97     if (ret.ne.0) then
98        print *, "Erreur a la lecture du nombre de composantes : ",ncomp
99        cret = -1
100     endif
101
102     ! ** allocation memoire de comp et unit **
103     allocate(comp(ncomp),unit(ncomp),STAT=retmem)
104     if (retmem .ne. 0) then
105        print *, "Erreur a l'allocation mémoire de comp et unit : "
106        call efexit(-1)
107     endif
108
109     ! ** Info sur les champs
110     call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
111     if (ret .ne. 0) then
112        print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
113        cret = -1
114        continue
115     endif
116
117     write(*,'(/5X,A,A)') 'Nom du champ  : ', TRIM(nomcha)
118     write(*,'(/5X,A,A)') 'Nom du maillage : ',TRIM(maa)
119     write(*,'(5X,A,I5)') 'Type du champ : ', typcha
120     do j=1,ncomp
121        write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,'  : ',TRIM(comp(j)),' ',TRIM(unit(j))
122     enddo
123     write(*,'(5X,A,I1)') 'Nombre de pas de temps = ',ncst
124     print *,""
125
126     deallocate(comp,unit)
127
128     if (  (index(nomcha,"champ entier") .eq. 1) .and. &
129          (len_trim(nomcha) .eq. len("champ entier") )  ) then
130
131        lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE, USER_INTERLACE, ncst)
132        ! print *,lret
133
134        if (lret .eq. 0) then
135           lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_CELL, USER_INTERLACE, ncst)
136        else
137           print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
138        endif
139
140        if (lret .eq. 0) then
141           lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_FACE,USER_INTERLACE, ncst)
142        else
143           print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
144        endif
145
146        if (lret .eq. 0) then
147           lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_EDGE,USER_INTERLACE, ncst)
148        else
149           print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
150        endif
151
152        if (lret .eq. 0) then
153           lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE_ELEMENT,USER_INTERLACE, ncst)
154        else
155           print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
156        endif
157
158        if  (lret .ne. 0) then
159           print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
160        endif
161     else
162        print *, "There is no API yet for reading field on multiple meshes"
163     endif
164  enddo
165
166
167  call mpfnpf(fid,nval,ret)
168  write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
169
170  if (nval .gt. 0 ) then
171     do i=1,nval
172           call mpfpfi(fid,i,pflname,nval,ret)
173        write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
174     enddo
175  endif
176
177
178  !  ** Interrogation des liens **
179  call mlnnln(fid,nln,ret)
180  if (ret.ne.0) then
181     print *,"Erreur a la lecture du nombre de liens : " &
182          & ,nln
183     cret = -1;
184  else
185     print *,""
186     write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
187     do i=1,nln
188        call mlnlni(fid, i, nomlien, nval, ret)
189        if (ret.ne.0) then
190           print *,"Erreur a la demande d'information sur le lien n° : ",i
191           cret = -1;continue;
192        endif
193        write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval
194        !! allocate
195        lien = ""
196        call mlnlir(fid,nomlien,lien,ret)
197        if (ret.ne.0) then
198           print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
199           ret = -1;
200        else
201           write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,""
202        endif
203        !!deallocate
204     end do
205  endif
206
207
208  !  ** Interrogation des localisations des points de GAUSS **
209  call mlcnlc(fid,nloc,ret)
210  if (ret.ne.0) then
211     print *,"Erreur a la lecture du nombre de points de Gauss : " &
212          & ,nloc
213     cret = -1;
214  else
215     print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
216     do i=1,nloc
217        call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
218        if (ret.ne.0) then
219           print *,"Erreur a la demande d'information sur la localisation n° : ",i
220           cret = -1;continue;
221        endif
222        write (*,'(5X,A,I4,A,A,A,I4,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) &
223             &,"| et nbr. de pts Gauss ",ngauss,"| et dans un espace de dimension ",sdim
224        t1 = MOD(type_geo,100)*sdim
225        t2 = ngauss*sdim
226        t3 = ngauss
227        allocate(refcoo(t1),STAT=retmem)
228        if (retmem .ne. 0) then
229           print *, "Erreur a l'allocation mémoire de refcoo : "
230           call efexit(-1)
231        endif;
232        allocate(gscoo(t2),STAT=retmem)
233        if (retmem .ne. 0) then
234           print *, "Erreur a l'allocation mémoire de gscoo : "
235           call efexit(-1)
236        endif;
237        allocate(wg(t3),STAT=retmem)
238        if (retmem .ne. 0) then
239           print *, "Erreur a l'allocation mémoire de wg : "
240           call efexit(-1)
241        endif;
242        call mlclor(fid, locname,USER_INTERLACE,refcoo,gscoo,wg, ret )
243        if (ret.ne.0) then
244           print *,"Erreur a la lecture  des valeurs de la localisation : " &
245                & ,locname
246           cret = -1;
247        else
248           write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
249           do j=1,t1
250              write (*,'(5X,E20.8)') refcoo(j)
251           enddo
252           print *,""
253           write (*,'(5X,A)') "Localisation des points de GAUSS : "
254           do j=1,t2
255              write (*,'(5X,E20.8)') gscoo(j)
256           enddo
257           print *,""
258           write (*,'(5X,A)') "Poids associes aux points de GAUSS "
259           do j=1,t3
260              write (*,'(5X,E20.8)') wg(j)
261           enddo
262           print *,""
263        endif
264        deallocate(refcoo)
265        deallocate(gscoo)
266        deallocate(wg)
267     enddo
268  endif
269
270  call mficlo(fid,ret)
271  !print *,ret
272
273  call efexit(cret)
274
275end program test11
276
277
278integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
279  implicit none
280  include 'med.hf90'
281
282  integer*8    fid
283  integer      ::typcha,ncomp,entite,stockage, ncst
284  character(LEN=*)  nomcha
285
286  integer      :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
287  integer      :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
288  integer,     allocatable, dimension(:) :: pflval
289  integer,     allocatable, dimension(:) :: vale
290  integer      :: numdt,numo,lnsize,nbrefmaa
291  real*8,      allocatable, dimension(:) :: valr
292  real*8       dt
293  logical      local
294  character*64 :: pflname,locname,maa_ass
295  character*16 :: dt_unit
296  character*255:: lien
297  integer       USER_MODE
298
299  integer,pointer,dimension(:) :: type_geo
300  integer,target  :: typ_noeud(1) = (/ MED_NONE /)
301
302  integer :: MY_NOF_CELL_TYPE = 17
303  integer :: MY_NOF_DESCENDING_FACE_TYPE =  5
304  integer :: MY_NOF_DESCENDING_EDGE_TYPE =  2
305
306  integer,target  :: typmai(17) =  (/ MED_POINT1,MED_SEG2,   &
307       &  MED_SEG3,MED_TRIA3,     &
308       &  MED_QUAD4,MED_TRIA6,    &
309       &  MED_QUAD8,MED_TETRA4,   &
310       &  MED_PYRA5,MED_PENTA6,   &
311       &  MED_HEXA8,MED_TETRA10,  &
312       &  MED_PYRA13,MED_PENTA15,  &
313       &  MED_HEXA20,MED_POLYGON,&
314       &  MED_POLYHEDRON/)
315
316  integer,target :: typfac(5) = (/MED_TRIA3,MED_TRIA6,       &
317       &  MED_QUAD4,MED_QUAD8,MED_POLYGON/)
318  integer,target ::typare(2) = (/MED_SEG2,MED_SEG3/)
319
320  character(LEN=15),pointer,dimension(:) :: AFF
321  character(LEN=15),target,dimension(17) :: FMED_GEOMETRIE_MAILLE_AFF = (/&
322       &  "MED_POINT1     ",&
323       &  "MED_SEG2       ",&
324       &  "MED_SEG3       ",&
325       &  "MED_TRIA3      ",&
326       &  "MED_QUAD4      ",&
327       &  "MED_TRIA6      ",&
328       &  "MED_QUAD8      ",&
329       &  "MED_TETRA4     ",&
330       &  "MED_PYRA5      ",&
331       &  "MED_PENTA6     ",&
332       &  "MED_HEXA8      ",&
333       &  "MED_TETRA10    ",&
334       &  "MED_PYRA13     ",&
335       &  "MED_PENTA15    ",&
336       &  "MED_HEXA20     ",&
337       &  "MED_POLYGON    ",&
338       &  "MED_POLYHEDRON "  /)
339
340  character(LEN=15),target,dimension(5) :: FMED_GEOMETRIE_FACE_AFF = (/&
341       &  "MED_TRIA3      ",&
342       &  "MED_TRIA6      ",&
343       &  "MED_QUAD4      ",&
344       &  "MED_QUAD8      ",&
345       &  "MED_POLYGON    " /)
346
347  character(LEN=15),target,dimension(2) :: FMED_GEOMETRIE_ARETE_AFF = (/&
348       &  "MED_SEG2       ",&
349       &  "MED_SEG3       " /)
350
351  character(LEN=15),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/ &
352       &  "(AUCUN)        "/)
353
354
355  character(LEN=20),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/ &
356       &  "MED_CELL            ", &
357       &  "MED_DESCENDING_FACE ", &
358       &  "MED_DESCENDING_EDGE ", &
359       &  "MED_NODE            ", &
360       &  "MED_NODE_ELEMENT    "/)
361
362  parameter (USER_MODE = MED_COMPACT_PFLMODE )
363
364  !!  write (*,'(A0)')  FMED_GEOMETRIE_NOEUD_AFF(1)
365  !!  write (*,'(A0)')  FMED_GEOMETRIE_MAILLE_AFF(1)
366  !!  write (*,'(A0)')  FMED_GEOMETRIE_FACE_AFF(1)
367  !!  write (*,'(A0)')  FMED_GEOMETRIE_ARETE_AFF(1)
368
369  locname=''
370  nbpdtnor=0;pflsize=0;ngauss=0;nent=0
371  numdt = 0;numo=0;retmem=0
372  cret=0;ret=0
373
374  nullify(type_geo)
375  nullify(AFF)
376
377
378  select case (entite)
379  case (MED_NODE)
380     type_geo => typ_noeud
381     nb_geo   = 1
382     AFF      => FMED_GEOMETRIE_NOEUD_AFF
383  case (MED_CELL)
384     type_geo => typmai
385     nb_geo   = 17
386     AFF      => FMED_GEOMETRIE_MAILLE_AFF
387  case (MED_NODE_ELEMENT)
388     type_geo => typmai
389     nb_geo   = 17
390     AFF      => FMED_GEOMETRIE_MAILLE_AFF
391  case (MED_DESCENDING_FACE)
392     type_geo => typfac;
393     nb_geo   = 5
394     AFF      =>  FMED_GEOMETRIE_FACE_AFF
395  case  (MED_DESCENDING_EDGE)
396     type_geo => typare
397     nb_geo   = MY_NOF_DESCENDING_EDGE_TYPE
398     AFF      =>  FMED_GEOMETRIE_ARETE_AFF
399  end select
400
401  do k=1,nb_geo
402
403     ! ** Combien de (PDT,NOR) a lire **
404     nbpdtnor = ncst
405     if(nbpdtnor < 1 ) continue
406
407     do j=1,ncst
408
409        call mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
410        !print *,ret
411        if (ret.ne.0) then
412           print *, "Erreur a la demande d'information sur (pdt,nor) : " &
413                & ,nomcha,entite, numdt, numo, dt
414           cret = -1
415        end if
416
417        call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
418        !print *,ret
419        if (ret.ne.0) then
420           print *, "Erreur a la lecture du nombre de profil : " &
421                & ,nomcha,entite, type_geo(k),numdt, numo
422           cret = -1
423           call efexit(cret)
424        end if
425
426        do l=1,nprofile
427
428           ! ** Combien de valeurs à lire ? **
429           call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
430           !print *,ret
431           if (ret.ne.0) then
432              print *,"Erreur a la lecture du nombre de valeurs du champ : " &
433                   & ,nomcha,entite,type_geo(k), &
434                   & numdt, numo
435              cret = -1; continue
436           endif
437           !write(*,'(5X,A,I5,A)')  'Il y a ', nent ,' valeurs a lire '
438
439           write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)')  'Séquence de calcul n° ',l,' (',numdt,',',numo,'), dt=(',dt,')'
440           write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
441                & 'Il y a ',nent,' valeurs en mode ',USER_MODE, &
442                & '. Chaque entite ',TRIM(FMED_ENTITE_MAILLAGE_AFF(entite)), &
443                & ' de type geometrique ',TRIM(AFF(k)),' associes au profil |',&
444                & TRIM(pflname)//'| a ',ngauss,' valeur(s) par entité, et une localization de nom |',TRIM(locname)//'|'
445
446           ! **Lecture des valeurs du champ **
447           if (typcha .eq. MED_FLOAT64) then
448              allocate(valr(ncomp*nent*ngauss),STAT=retmem)
449
450              call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
451                   &      pflname,stockage,MED_ALL_CONSTITUENT,valr,ret)
452              !print *,ret
453              if (ret.ne.0) then
454                 print *,"Erreur a la lecture des valeurs du champ : ", &
455                      &  nomcha,valr,stockage,MED_ALL_CONSTITUENT, &
456                      &  pflname,USER_MODE,entite,type_geo(k),numdt,numo
457                 cret = -1;
458                 call efexit(cret)
459              endif
460           else
461              allocate(vale(ncomp*nent*ngauss),STAT=retmem)
462
463              call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
464                   &      pflname,stockage,MED_ALL_CONSTITUENT,vale,ret)
465              !print *,ret
466              if (ret.ne.0) then
467                 print *,"Erreur a la lecture des valeurs du champ : ",&
468                      & nomcha,vale,stockage,MED_ALL_CONSTITUENT, &
469                      & pflname,USER_MODE,entite,type_geo(k),numdt,numo
470                 cret = -1;
471              endif
472
473           endif
474
475           if (ngauss .gt. 1 ) then
476              write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
477                   & "points de Gauss de nom ", TRIM(locname)
478           end if
479
480           if ( entite .eq. MED_NODE_ELEMENT ) then
481              ngroup = MOD(type_geo(k),100)
482           else
483              ngroup = ngauss
484           end if
485
486           select case (stockage)
487           case (MED_FULL_INTERLACE)
488              write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
489              do m=0,nent-1
490                 write(*,*) "|"
491                 do n=0,(ngroup*ncomp-1)
492                    if (typcha .eq. MED_FLOAT64) then
493                       write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
494                    else
495                       write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
496                    end if
497                 enddo
498              enddo
499           case (MED_NO_INTERLACE)
500              write(*,'(5X,A)') "- Valeurs :";  write(*,'(5X,A)') ""
501              do m=0,ncomp-1
502                 write(*,*) "|"
503                 do n=0,nent-1
504                    if (typcha .eq. MED_FLOAT64) then
505                       write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
506                    else
507                       write (*,'(1X,I8,1X)') vale(m*nent+n +1)
508                    endif
509                 enddo
510              enddo
511           end select
512
513           write(*,*) "|"
514           if (typcha .eq. MED_FLOAT64) then
515              deallocate(valr)
516           else
517              deallocate(vale)
518           endif
519
520           !* Profils
521           if (pflname .eq. MED_NO_PROFILE) then
522              !write(*,'(5X,A)') 'Pas de profil'
523           else
524              write(*,'(5X,A,A)') 'Profil :',pflname
525              call mpfpsn(fid,pflname,pflsize,ret)
526              if (ret .ne. 0) then
527                 print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
528                      & pflname,pflsize
529                 cret = -1;continue
530              endif
531              write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
532
533              ! ** allocation memoire de pflval **
534              allocate(pflval(pflsize),STAT=retmem)
535              if (retmem .ne. 0) then
536                 print *, "Erreur a l'allocation mémoire de pflsize : "
537                 call efexit(-1)
538              endif
539
540              call mpfprr(fid,pflname,pflval,ret)
541              if (cret .ne. 0) write(*,'(I1)') cret
542              if (ret .ne. 0) then
543                 print *,"Erreur a la lecture du profil : ", &
544                      & pflname,pflval
545                 cret = -1;continue
546              endif
547              write(*,'(5X,A)') 'Valeurs du profil : '
548              do m=1,pflsize
549                 write (*,'(5X,I6)') pflval(m)
550              enddo
551
552              deallocate(pflval)
553
554           endif
555
556        enddo
557
558     enddo
559
560  enddo
561
562  print *,""
563  getFieldsOn=ret
564
565end function getFieldsOn
566