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 ! ****************************************************************************** 21 ! * - Nom du fichier : test11.f90 22 ! * 23 ! * - Description : lecture de champs de resultats MED 24 ! * 25 ! ***************************************************************************** 26 27 program test11 28 29 implicit none 30 include 'med.hf' 31 32 33 integer cret,ret,lret,retmem, fid 34 integer USER_INTERLACE,USER_MODE 35 character*32 :: 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 49 parameter (USER_INTERLACE = MED_FULL_INTERLACE) 50 parameter (USER_MODE = MED_COMPACT ) 51 52 cret=0;ret=0;lret=0;retmem=0 53 print *,"Indiquez le fichier med a decrire : " 54 !!read(*,'(A)') argc 55 argc="test10.med" 56 57 ! ** ouverture du fichier ** 58 call efouvr(fid,argc,MED_LECTURE, ret) 59 if (ret .ne. 0) call efexit(-1) 60 61 ! ** info sur le premier maillage ** 62 call efmaai(fid,1,maa,mdim,type,desc,ret) 63 if (ret.ne.0) then 64 print *, "Erreur a la lecture des informations sur le maillage : ", & 65 & maa,mdim,type,desc 66 call efexit(-1) 67 endif 68 69 write (*,'(/A,A,A,I1)') "Maillage de nom |",TRIM(maa),"| et de dimension ",mdim 70 71 ! ** combien de champs dans le fichier ** 72 call efncha(fid,0,ncha,ret) 73 if (ret.ne.0) then 74 print *, "Impossible de lire le nombre de champs : ",ncha 75 call efexit(-1) 76 endif 77 78 write (*,'(A,I1/)') "Nombre de champs : ",ncha 79 80 81 ! ** lecture de tous les champs associes a <maa> ** 82 do i=1,ncha 83 lret = 0 84 write(*,'(A,I5)') "- Champ numero : ",i 85 86 ! ** combien de composantes ** 87 call efncha(fid,i,ncomp,ret) 88 if (ret.ne.0) then 89 print *, "Erreur a la lecture du nombre de composantes : ",ncomp 90 cret = -1 91 endif 92 93 ! ** allocation memoire de comp et unit ** 94 allocate(comp(ncomp),unit(ncomp),STAT=retmem) 95 if (retmem .ne. 0) then 96 print *, "Erreur a l'allocation mémoire de comp et unit : " 97 call efexit(-1) 98 endif 99 100 ! ** Info sur les champs 101 call efchai(fid,i,nomcha,typcha,comp,unit,ncomp,ret) 102 if (ret .ne. 0) then 103 print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp 104 cret = -1 105 continue 106 endif 107 108 write(*,'(/5X,A,A)') 'Nom du champ : ', TRIM(nomcha) 109 write(*,'(5X,A,I5)') 'Type du champ : ', typcha 110 do j=1,ncomp 111 write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,' : ',TRIM(comp(j)),' ',TRIM(unit(j)) 112 enddo 113 114 deallocate(comp,unit) 115 print *,"" 116 117 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NOEUD, USER_INTERLACE ) 118 119 if (lret .eq. 0) then 120 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_MAILLE, USER_INTERLACE ) 121 else 122 print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue 123 endif 124 125 if (lret .eq. 0) then 126 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_FACE,USER_INTERLACE) 127 else 128 print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue 129 endif 130 131 if (lret .eq. 0) then 132 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_ARETE,USER_INTERLACE) 133 else 134 print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue 135 endif 136 137 if (lret .eq. 0) then 138 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NOEUD_MAILLE,USER_INTERLACE) 139 else 140 print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue 141 endif 142 143 if (lret .ne. 0) then 144 print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1 145 endif 146 147 enddo 148 149 150 call efnpro(fid,nval,ret) 151 write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval 152 153 if (nval .gt. 0 ) then 154 do i=1,nval 155 call efproi(fid,i,pflname,nval,ret) 156 write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval 157 enddo 158 endif 159 160 ! ** Interrogation des liens ** 161 call efnlie(fid,nln,ret) 162 if (ret.ne.0) then 163 print *,"Erreur a la lecture du nombre de liens : " & 164 & ,nln 165 cret = -1; 166 else 167 print *,"" 168 print *,"Nombre de liens stockes : ",nln;print *,"";print *,"" 169 do i=1,nln 170 call efliei(fid, i, nomlien, nval, ret) 171 if (ret.ne.0) then 172 print *,"Erreur a la demande d'information sur le lien n° : ",i 173 cret = -1;continue; 174 endif 175 write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval 176 !! allocate 177 lien = "" 178 call efliel(fid,lien,nval,nomlien,ret) 179 if (ret.ne.0) then 180 print *,"Erreur a la lecture du lien : ", lien,nval,nomlien 181 ret = -1; 182 else 183 write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,"" 184 endif 185 !!deallocate 186 end do 187 endif 188 189 ! ** Interrogation des localisations des points de GAUSS ** 190 call efngau(fid,nloc,ret) 191 if (ret.ne.0) then 192 print *,"Erreur a la lecture du nombre de points de Gauss : " & 193 & ,nloc 194 cret = -1; 195 else 196 print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,"" 197 do i=1,nloc 198 call efgaui(fid, i, locname, type_geo, ngauss, ret) 199 if (ret.ne.0) then 200 print *,"Erreur a la demande d'information sur la localisation n° : ",i 201 cret = -1;continue; 202 endif 203 write (*,'(5X,A,I4,A,A,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) & 204 &,"| et nbr. de pts Gauss ",ngauss 205 t1 = MOD(type_geo,100)*(type_geo/100) 206 t2 = ngauss*(type_geo/100) 207 t3 = ngauss 208 allocate(refcoo(t1),STAT=retmem) 209 if (retmem .ne. 0) then 210 print *, "Erreur a l'allocation mémoire de refcoo : " 211 call efexit(-1) 212 endif; 213 allocate(gscoo(t2),STAT=retmem) 214 if (retmem .ne. 0) then 215 print *, "Erreur a l'allocation mémoire de gscoo : " 216 call efexit(-1) 217 endif; 218 allocate(wg(t3),STAT=retmem) 219 if (retmem .ne. 0) then 220 print *, "Erreur a l'allocation mémoire de wg : " 221 call efexit(-1) 222 endif; 223 call efgaul(fid, refcoo, gscoo, wg, USER_INTERLACE, locname, ret ) 224 if (ret.ne.0) then 225 print *,"Erreur a la lecture des valeurs de la localisation : " & 226 & ,locname 227 cret = -1; 228 else 229 write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo 230 do j=1,t1 231 write (*,'(5X,E20.8)') refcoo(j) 232 enddo 233 print *,"" 234 write (*,'(5X,A)') "Localisation des points de GAUSS : " 235 do j=1,t2 236 write (*,'(5X,E20.8)') gscoo(j) 237 enddo 238 print *,"" 239 write (*,'(5X,A)') "Poids associes aux points de GAUSS " 240 do j=1,t3 241 write (*,'(5X,E20.8)') wg(j) 242 enddo 243 print *,"" 244 endif 245 deallocate(refcoo) 246 deallocate(gscoo) 247 deallocate(wg) 248 enddo 249 endif 250 251 call efferm (fid,ret) 252 253 call efexit(cret) 254 255 end program test11 256 257 258 integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage) 259 implicit none 260 include 'med.hf' 261 262 integer ::fid,typcha,ncomp,entite,stockage 263 character(LEN=*) nomcha 264 265 integer :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref 266 integer :: nbpdtnor,pflsize,ngauss,ngroup,nval 267 integer, allocatable, dimension(:) :: pflval 268 integer, allocatable, dimension(:) :: vale 269 integer :: numdt,numo,lnsize,nbrefmaa 270 real*8, allocatable, dimension(:) :: valr 271 real*8 dt 272 logical local 273 character*32 :: pflname,locname,maa_ass 274 character*16 :: dt_unit 275 character*255:: lien 276 integer USER_MODE 277 278 integer,pointer,dimension(:) :: type_geo 279 integer,target :: typ_noeud(1) = (/ MED_NONE /) 280 integer,target :: typmai(MED_NBR_GEOMETRIE_MAILLE+2) = (/ MED_POINT1,MED_SEG2, & 281 & MED_SEG3,MED_TRIA3, & 282 & MED_QUAD4,MED_TRIA6, & 283 & MED_QUAD8,MED_TETRA4, & 284 & MED_PYRA5,MED_PENTA6, & 285 & MED_HEXA8,MED_TETRA10, & 286 & MED_PYRA13,MED_PENTA15, & 287 & MED_HEXA20,MED_POLYGONE,& 288 & MED_POLYEDRE/) 289 290 integer,target :: typfac(MED_NBR_GEOMETRIE_FACE+1) = (/MED_TRIA3,MED_TRIA6, & 291 & MED_QUAD4,MED_QUAD8,MED_POLYGONE/) 292 integer,target ::typare(MED_NBR_GEOMETRIE_ARETE) = (/MED_SEG2,MED_SEG3/) 293 294 character(LEN=12),pointer,dimension(:) :: AFF 295 character(LEN=12),target,dimension(MED_NBR_GEOMETRIE_MAILLE+2) :: FMED_GEOMETRIE_MAILLE_AFF = (/& 296 & "MED_POINT1 ",& 297 & "MED_SEG2 ",& 298 & "MED_SEG3 ",& 299 & "MED_TRIA3 ",& 300 & "MED_QUAD4 ",& 301 & "MED_TRIA6 ",& 302 & "MED_QUAD8 ",& 303 & "MED_TETRA4 ",& 304 & "MED_PYRA5 ",& 305 & "MED_PENTA6 ",& 306 & "MED_HEXA8 ",& 307 & "MED_TETRA10 ",& 308 & "MED_PYRA13 ",& 309 & "MED_PENTA15 ",& 310 & "MED_HEXA20 ",& 311 & "MED_POLYGONE",& 312 & "MED_POLYEDRE" /) 313 314 character(LEN=12),target,dimension(MED_NBR_GEOMETRIE_FACE+1) :: FMED_GEOMETRIE_FACE_AFF = (/& 315 & "MED_TRIA3 ",& 316 & "MED_TRIA6 ",& 317 & "MED_QUAD4 ",& 318 & "MED_QUAD8 ",& 319 & "MED_POLYGONE" /) 320 321 character(LEN=12),target,dimension(MED_NBR_GEOMETRIE_ARETE) :: FMED_GEOMETRIE_ARETE_AFF = (/& 322 & "MED_SEG2 ",& 323 & "MED_SEG3 " /) 324 325 character(LEN=12),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/ & 326 & "(AUCUN) "/) 327 328 329 character(LEN=17),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/ & 330 & "MED_MAILLE ", & 331 & "MED_FACE ", & 332 & "MED_ARETE ", & 333 & "MED_NOEUD ", & 334 & "MED_NOEUD_MAILLE "/) 335 336 parameter (USER_MODE = MED_COMPACT ) 337 338 !! write (*,'(A0)') FMED_GEOMETRIE_NOEUD_AFF(1) 339 !! write (*,'(A0)') FMED_GEOMETRIE_MAILLE_AFF(1) 340 !! write (*,'(A0)') FMED_GEOMETRIE_FACE_AFF(1) 341 !! write (*,'(A0)') FMED_GEOMETRIE_ARETE_AFF(1) 342 343 nbpdtnor=0;pflsize=0;ngauss=0;nval=0 344 numdt = 0;numo=0;retmem=0 345 cret=0;ret=0 346 347 nullify(type_geo) 348 nullify(AFF) 349 350 351 select case (entite) 352 case (MED_NOEUD) 353 type_geo => typ_noeud 354 nb_geo = 1 355 AFF => FMED_GEOMETRIE_NOEUD_AFF 356 case (MED_MAILLE) 357 type_geo => typmai 358 nb_geo = MED_NBR_GEOMETRIE_MAILLE+2 359 AFF => FMED_GEOMETRIE_MAILLE_AFF 360 case (MED_NOEUD_MAILLE) 361 type_geo => typmai 362 nb_geo = MED_NBR_GEOMETRIE_MAILLE+2 363 AFF => FMED_GEOMETRIE_MAILLE_AFF 364 case (MED_FACE) 365 type_geo => typfac; 366 nb_geo = MED_NBR_GEOMETRIE_FACE+1 367 AFF => FMED_GEOMETRIE_FACE_AFF 368 case (MED_ARETE) 369 type_geo => typare 370 nb_geo = MED_NBR_GEOMETRIE_ARETE 371 AFF => FMED_GEOMETRIE_ARETE_AFF 372 end select 373 374 do k=1,nb_geo 375 376 ! ** Combien de (PDT,NOR) a lire ** 377 call efnpdt(fid,nomcha,entite,type_geo(k),nbpdtnor,ret) 378 if (ret.ne.0) then 379 print *, "Impossible de lire le nombre de pas de temps : " & 380 & ,k,nomcha,entite,FMED_ENTITE_MAILLAGE_AFF(entite) & 381 & ,type_geo(k),AFF(type_geo(k)) 382 cret = -1 383 end if 384 if(nbpdtnor < 1 ) continue 385 386 do j=1,nbpdtnor 387 388 389 call efpdti(fid, nomcha, entite, type_geo(k), & 390 & j, ngauss, numdt, numo, dt_unit, & 391 & dt, maa_ass, local, nbrefmaa, ret ) 392 if (ret.ne.0) then 393 print *, "Erreur a la demande d'information sur (pdt,nor) : " & 394 & ,nomcha,entite, type_geo(k), ngauss, numdt, numo, dt_unit & 395 & ,dt, maa_ass, local, nbrefmaa 396 cret = -1 397 end if 398 399 if (numdt .eq. MED_NOPDT) then 400 write(*,'(5X,A)') 'Pas de pas de temps' 401 else 402 write(*,'(5X,A,I5,A,E20.8,A,A,A)') 'Pas de temps n° ' & 403 & ,numdt,' (', dt ,') ', 'et d''unite ',TRIM(dt_unit) 404 endif 405 if (numo .eq. MED_NONOR) then 406 write(*,'(5X,A)') 'Pas de numero d''ordre' 407 else 408 write(*,'(5X,A,I5)') 'Numero d ordre : ', numo 409 endif 410 write(*,'(5X,A,I5)') 'Nombre de points de gauss : ',ngauss 411 write(*,'(5X,A,A)') 'Maillage associe : ', TRIM(maa_ass) 412 413 ! ** Le maillage reference est-il porte par un autre fichier ** 414 if ( .not. local ) then 415 call efnvli(fid,maa_ass,nvl,ret) 416 if (ret.ne.0) then 417 print *, "Erreur a la lecture de la taille du lien : " & 418 & , maa_ass, local, nvl 419 cret = -1 420 end if 421 !! allocate(lien(nvl),STAT=retmem) 422 if (retmem .ne. 0) then 423 print *, "Erreur a l'allocation mémoire de lien : " 424 call efexit(-1) 425 endif 426 lien ="" 427 call efliel(fid,lien,nvl,maa_ass,ret) 428 if (ret.ne.0) then 429 print *,"Erreur a la lecture du lien : " & 430 & ,maa_ass,lien 431 cret = -1 432 else 433 write (*,'(5X,A,A,A,A,A)') 'Le maillage |',TRIM(maa_ass), & 434 & '| est porte par un fichier distant |', & 435 & TRIM(lien),'|' 436 endif 437 !! deallocate(lien) 438 endif 439 440 ! ** Combien de maillages lies aux (nomcha,ent,geo,numdt,numo) ** 441 ! ** Notons que cette information est egalement disponible ** 442 ! ** a partir de MEDpasdetempsInfo ** 443 call efnref(fid,nomcha,entite,type_geo(k),numdt,numo,nref,ret) 444 if (ret.ne.0) then 445 print *,"Erreur a la demande du nombre de maillages references par le champ : ", & 446 & nomcha,numdt,numo 447 cret = -1; continue 448 endif 449 450 do l=1,nbrefmaa 451 452 call efrefi(fid,nomcha,entite,type_geo(k), & 453 & l,numdt, numo, maa_ass, local, ngauss, ret) 454 if (ret.ne.0) then 455 print *,"Erreur a la demande d'information sur le maillage utilise par le champ n° : " & 456 & ,nomcha,entite,type_geo(k), & 457 & l,numdt, numo, maa_ass 458 cret = -1; continue 459 endif 460 461 ! ** Prend en compte le nbre de pt de gauss automatiquement ** 462 call efnval(fid,nomcha,entite,type_geo(k),numdt,numo,maa_ass,USER_MODE,nval,cret) 463 if (ret.ne.0) then 464 print *,"Erreur a la lecture du nombre de valeurs du champ : " & 465 & ,nomcha,entite,type_geo(k), & 466 & numdt, numo, maa_ass 467 cret = -1; continue 468 endif 469 write(*,'(5X,A,I5,A,I5,A,A,A,A,A,A,A,I5,A)') & 470 & 'Il y a ',nval,' valeurs en mode ',USER_MODE, & 471 & ' . Chaque entite ',TRIM(FMED_ENTITE_MAILLAGE_AFF(entite)), & 472 & ' de type geometrique ',TRIM(AFF(k)),' associes au maillage |',& 473 & TRIM(maa_ass),'| a ',ngauss,' pts de gauss ' 474 475 ! ** Le maillage reference est-il porte par un autre fichier ** 476 if ( .not. local ) then 477 478 call efnvli(fid,maa_ass,nvl,ret) 479 if (ret.ne.0) then 480 print *, "Erreur a la lecture de la taille du lien : " & 481 & , maa_ass, local, nvl 482 cret = -1 483 end if 484 485 !! allocate(lien(nvl),STAT=retmem) 486 if (retmem .ne. 0) then 487 print *, "Erreur a l'allocation mémoire de comp et unit : " 488 call efexit(-1) 489 endif 490 491 call efliel(fid,lien,nvl,maa_ass,ret) 492 if (ret.ne.0) then 493 print *,"Erreur a la lecture du lien : " & 494 & ,maa_ass,lien 495 cret = -1 496 else 497 write(*,'(5X,A,A,A,A,A)') 'Le maillage |',TRIM(maa_ass), & 498 & '| est porte par un fichier distant |',TRIM(lien),'|' 499 endif 500 !! deallocate(lien) 501 endif 502 503 ! **Lecture des valeurs du champ ** 504 if (typcha .eq. MED_FLOAT64) then 505 allocate(valr(ncomp*nval),STAT=retmem) 506 507 call efchal(fid,maa_ass,nomcha,valr,stockage,MED_ALL,locname, & 508 & pflname,USER_MODE,entite,type_geo(k),numdt,numo,ret) 509 510 if (ret.ne.0) then 511 print *,"Erreur a la lecture du nombre de valeurs du champ : ", & 512 & maa_ass,nomcha,valr,stockage,MED_ALL,locname, & 513 & pflname,USER_MODE,entite,type_geo(k),numdt,numo 514 cret = -1; 515 endif 516 else 517 allocate(vale(ncomp*nval),STAT=retmem) 518 519 call efchal(fid,maa_ass,nomcha,vale,stockage,MED_ALL,locname, & 520 & pflname,USER_MODE,entite,type_geo(k),numdt,numo,ret) 521 if (ret.ne.0) then 522 print *,"Erreur a la lecture des valeurs du champ : ",& 523 & maa_ass,nomcha,vale,stockage,MED_ALL,locname, & 524 & pflname,USER_MODE,entite,type_geo(k),numdt,numo 525 cret = -1; 526 endif 527 528 endif 529 530 if (ngauss .gt. 1 ) then 531 write (*,'(5X,A,A,A)') "- Modèle de localisation des ", & 532 & "points de Gauss de nom ", TRIM(locname) 533 end if 534 535 if ( entite .eq. MED_NOEUD_MAILLE ) then 536 ngroup = MOD(type_geo(k),100) 537 else 538 ngroup = ngauss 539 end if 540 541 select case (stockage) 542 case (MED_FULL_INTERLACE) 543 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') "" 544 do m=0,(nval/ngroup-1) 545 write(*,*) "|" 546 do n=0,(ngroup*ncomp-1) 547 if (typcha .eq. MED_FLOAT64) then 548 write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 ) 549 else 550 write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 ) 551 end if 552 enddo 553 enddo 554 case (MED_NO_INTERLACE) 555 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') "" 556 do m=0,ncomp-1 557 write(*,*) "|" 558 do n=0,nval-1 559 if (typcha .eq. MED_FLOAT64) then 560 write (*,'(1X,E20.5,1X)') valr(m*nval+n +1) 561 else 562 write (*,'(1X,I8,1X)') vale(m*nval+n +1) 563 endif 564 enddo 565 enddo 566 end select 567 568 write(*,*) "|" 569 if (typcha .eq. MED_FLOAT64) then 570 deallocate(valr) 571 else 572 deallocate(vale) 573 endif 574 575 !* Profils 576 if (pflname .eq. MED_NOPFL) then 577 write(*,'(5X,A)') 'Pas de profil' 578 else 579 write(*,'(5X,A,A)') 'Profil :',pflname 580 call efnpfl(fid,pflname,pflsize,ret) 581 if (ret .ne. 0) then 582 print *,"Erreur a la lecture du nombre de valeurs du profil : ", & 583 & pflname,pflsize 584 cret = -1;continue 585 endif 586 write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize 587 588 ! ** allocation memoire de pflval ** 589 allocate(pflval(pflsize),STAT=retmem) 590 if (retmem .ne. 0) then 591 print *, "Erreur a l'allocation mémoire de pflsize : " 592 call efexit(-1) 593 endif 594 595 call efpfll(fid,pflval,pflname,ret) 596 if (cret .ne. 0) write(*,'(I1)') cret 597 if (ret .ne. 0) then 598 print *,"Erreur a la lecture du profil : ", & 599 & pflname,pflval 600 cret = -1;continue 601 endif 602 write(*,'(5X,A)') 'Valeurs du profil : ' 603 do m=1,pflsize 604 write (*,'(5X,I6)') pflval(m) 605 enddo 606 607 deallocate(pflval) 608 609 endif 610 611 enddo 612 613 enddo 614 615 enddo 616 617 print *,"" 618 getFieldsOn=ret 619 620 end function getFieldsOn