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