00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026 program test11
00027
00028 implicit none
00029 include 'med.hf'
00030
00031
00032 integer cret,ret,lret,retmem, fid
00033 integer USER_INTERLACE,USER_MODE
00034 character*32 :: maa,nomcha,pflname,nomlien,locname
00035 character*200 desc
00036 character*255 argc
00037 character*16, allocatable, dimension(:) :: comp,unit
00038 character*16 dtunit
00039 integer mdim,ncomp,ncha,npro,nln,pflsize,nval
00040 integer, allocatable, dimension(:) :: pflval
00041 integer ngauss,nloc
00042 integer t1,t2,t3,typcha,type,type_geo
00043 real*8, allocatable, dimension(:) :: refcoo, gscoo, wg
00044 character*255 lien
00045 integer i,j
00046 integer getFieldsOn
00047
00048 parameter (USER_INTERLACE = MED_FULL_INTERLACE)
00049 parameter (USER_MODE = MED_COMPACT )
00050
00051 cret=0;ret=0;lret=0;retmem=0
00052 print *,"Indiquez le fichier med a decrire : "
00053
00054 argc="test10.med"
00055
00056
00057 call efouvr(fid,argc,MED_LECTURE, ret)
00058 if (ret .ne. 0) call efexit(-1)
00059
00060
00061 call efmaai(fid,1,maa,mdim,type,desc,ret)
00062 if (ret.ne.0) then
00063 print *, "Erreur a la lecture des informations sur le maillage : ", &
00064 & maa,mdim,type,desc
00065 call efexit(-1)
00066 endif
00067
00068 write (*,'(/A,A,A,I1)') "Maillage de nom |",TRIM(maa),"| et de dimension ",mdim
00069
00070
00071 call efncha(fid,0,ncha,ret)
00072 if (ret.ne.0) then
00073 print *, "Impossible de lire le nombre de champs : ",ncha
00074 call efexit(-1)
00075 endif
00076
00077 write (*,'(A,I1/)') "Nombre de champs : ",ncha
00078
00079
00080
00081 do i=1,ncha
00082 lret = 0
00083 write(*,'(A,I5)') "- Champ numero : ",i
00084
00085
00086 call efncha(fid,i,ncomp,ret)
00087 if (ret.ne.0) then
00088 print *, "Erreur a la lecture du nombre de composantes : ",ncomp
00089 cret = -1
00090 endif
00091
00092
00093 allocate(comp(ncomp),unit(ncomp),STAT=retmem)
00094 if (retmem .ne. 0) then
00095 print *, "Erreur a l'allocation mémoire de comp et unit : "
00096 call efexit(-1)
00097 endif
00098
00099
00100 call efchai(fid,i,nomcha,typcha,comp,unit,ncomp,ret)
00101 if (ret .ne. 0) then
00102 print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp
00103 cret = -1
00104 continue
00105 endif
00106
00107 write(*,'(/5X,A,A)') 'Nom du champ : ', TRIM(nomcha)
00108 write(*,'(5X,A,I5)') 'Type du champ : ', typcha
00109 do j=1,ncomp
00110 write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,' : ',TRIM(comp(j)),' ',TRIM(unit(j))
00111 enddo
00112
00113 deallocate(comp,unit)
00114 print *,""
00115
00116 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NOEUD, USER_INTERLACE )
00117
00118 if (lret .eq. 0) then
00119 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_MAILLE, USER_INTERLACE )
00120 else
00121 print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
00122 endif
00123
00124 if (lret .eq. 0) then
00125 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_FACE,USER_INTERLACE)
00126 else
00127 print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
00128 endif
00129
00130 if (lret .eq. 0) then
00131 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_ARETE,USER_INTERLACE)
00132 else
00133 print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
00134 endif
00135
00136 if (lret .eq. 0) then
00137 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NOEUD_MAILLE,USER_INTERLACE)
00138 else
00139 print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
00140 endif
00141
00142 if (lret .ne. 0) then
00143 print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
00144 endif
00145
00146 enddo
00147
00148
00149 call efnpro(fid,nval,ret)
00150 write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
00151
00152 if (nval .gt. 0 ) then
00153 do i=1,nval
00154 call efproi(fid,i,pflname,nval,ret)
00155 write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
00156 enddo
00157 endif
00158
00159
00160 call efnlie(fid,nln,ret)
00161 if (ret.ne.0) then
00162 print *,"Erreur a la lecture du nombre de liens : " &
00163 & ,nln
00164 cret = -1;
00165 else
00166 print *,""
00167 print *,"Nombre de liens stockes : ",nln;print *,"";print *,""
00168 do i=1,nln
00169 call efliei(fid, i, nomlien, nval, ret)
00170 if (ret.ne.0) then
00171 print *,"Erreur a la demande d'information sur le lien n° : ",i
00172 cret = -1;continue;
00173 endif
00174 write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval
00175
00176 lien = ""
00177 call efliel(fid,lien,nval,nomlien,ret)
00178 if (ret.ne.0) then
00179 print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
00180 ret = -1;
00181 else
00182 write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,""
00183 endif
00184
00185 end do
00186 endif
00187
00188
00189 call efngau(fid,nloc,ret)
00190 if (ret.ne.0) then
00191 print *,"Erreur a la lecture du nombre de points de Gauss : " &
00192 & ,nloc
00193 cret = -1;
00194 else
00195 print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
00196 do i=1,nloc
00197 call efgaui(fid, i, locname, type_geo, ngauss, ret)
00198 if (ret.ne.0) then
00199 print *,"Erreur a la demande d'information sur la localisation n° : ",i
00200 cret = -1;continue;
00201 endif
00202 write (*,'(5X,A,I4,A,A,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) &
00203 &,"| et nbr. de pts Gauss ",ngauss
00204 t1 = MOD(type_geo,100)*(type_geo/100)
00205 t2 = ngauss*(type_geo/100)
00206 t3 = ngauss
00207 allocate(refcoo(t1),STAT=retmem)
00208 if (retmem .ne. 0) then
00209 print *, "Erreur a l'allocation mémoire de refcoo : "
00210 call efexit(-1)
00211 endif;
00212 allocate(gscoo(t2),STAT=retmem)
00213 if (retmem .ne. 0) then
00214 print *, "Erreur a l'allocation mémoire de gscoo : "
00215 call efexit(-1)
00216 endif;
00217 allocate(wg(t3),STAT=retmem)
00218 if (retmem .ne. 0) then
00219 print *, "Erreur a l'allocation mémoire de wg : "
00220 call efexit(-1)
00221 endif;
00222 call efgaul(fid, refcoo, gscoo, wg, USER_INTERLACE, locname, ret )
00223 if (ret.ne.0) then
00224 print *,"Erreur a la lecture des valeurs de la localisation : " &
00225 & ,locname
00226 cret = -1;
00227 else
00228 write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
00229 do j=1,t1
00230 write (*,'(5X,E20.8)') refcoo(j)
00231 enddo
00232 print *,""
00233 write (*,'(5X,A)') "Localisation des points de GAUSS : "
00234 do j=1,t2
00235 write (*,'(5X,E20.8)') gscoo(j)
00236 enddo
00237 print *,""
00238 write (*,'(5X,A)') "Poids associes aux points de GAUSS "
00239 do j=1,t3
00240 write (*,'(5X,E20.8)') wg(j)
00241 enddo
00242 print *,""
00243 endif
00244 deallocate(refcoo)
00245 deallocate(gscoo)
00246 deallocate(wg)
00247 enddo
00248 endif
00249
00250 call efferm (fid,ret)
00251
00252 call efexit(cret)
00253
00254 end program test11
00255
00256
00257 integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage)
00258 implicit none
00259 include 'med.hf'
00260
00261 integer ::fid,typcha,ncomp,entite,stockage
00262 character(LEN=*) nomcha
00263
00264 integer :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
00265 integer :: nbpdtnor,pflsize,ngauss,ngroup,nval
00266 integer, allocatable, dimension(:) :: pflval
00267 integer, allocatable, dimension(:) :: vale
00268 integer :: numdt,numo,lnsize,nbrefmaa
00269 real*8, allocatable, dimension(:) :: valr
00270 real*8 dt
00271 logical local
00272 character*32 :: pflname,locname,maa_ass
00273 character*16 :: dt_unit
00274 character*255:: lien
00275 integer USER_MODE
00276
00277 integer,pointer,dimension(:) :: type_geo
00278 integer,target :: typ_noeud(1) = (/ MED_NONE /)
00279 integer,target :: typmai(MED_NBR_GEOMETRIE_MAILLE+2) = (/ MED_POINT1,MED_SEG2,
00280 MED_SEG3,MED_TRIA3, &
00281 MED_QUAD4,MED_TRIA6, &
00282 MED_QUAD8,MED_TETRA4, &
00283 MED_PYRA5,MED_PENTA6, &
00284 MED_HEXA8,MED_TETRA10, &
00285 MED_PYRA13,MED_PENTA15, &
00286 MED_HEXA20,MED_POLYGONE,&
00287 MED_POLYEDRE/)
00288
00289 integer,target :: typfac(MED_NBR_GEOMETRIE_FACE+1) = (/MED_TRIA3,MED_TRIA6,
00290 MED_QUAD4,MED_QUAD8,MED_POLYGONE/)
00291 integer,target ::typare(MED_NBR_GEOMETRIE_ARETE) = (/MED_SEG2,MED_SEG3/)
00292
00293 character(LEN=12),pointer,dimension(:) :: AFF
00294 character(LEN=12),target,dimension(MED_NBR_GEOMETRIE_MAILLE+2) :: FMED_GEOMETRIE_MAILLE_AFF = (/
00295 "MED_POINT1 ",&
00296 "MED_SEG2 ",&
00297 "MED_SEG3 ",&
00298 "MED_TRIA3 ",&
00299 "MED_QUAD4 ",&
00300 "MED_TRIA6 ",&
00301 "MED_QUAD8 ",&
00302 "MED_TETRA4 ",&
00303 "MED_PYRA5 ",&
00304 "MED_PENTA6 ",&
00305 "MED_HEXA8 ",&
00306 "MED_TETRA10 ",&
00307 "MED_PYRA13 ",&
00308 "MED_PENTA15 ",&
00309 "MED_HEXA20 ",&
00310 "MED_POLYGONE",&
00311 "MED_POLYEDRE" /)
00312
00313 character(LEN=12),target,dimension(MED_NBR_GEOMETRIE_FACE+1) :: FMED_GEOMETRIE_FACE_AFF = (/
00314 "MED_TRIA3 ",&
00315 "MED_TRIA6 ",&
00316 "MED_QUAD4 ",&
00317 "MED_QUAD8 ",&
00318 "MED_POLYGONE" /)
00319
00320 character(LEN=12),target,dimension(MED_NBR_GEOMETRIE_ARETE) :: FMED_GEOMETRIE_ARETE_AFF = (/
00321 "MED_SEG2 ",&
00322 "MED_SEG3 " /)
00323
00324 character(LEN=12),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/
00325 "(AUCUN) "/)
00326
00327
00328 character(LEN=17),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/
00329 "MED_MAILLE ", &
00330 "MED_FACE ", &
00331 "MED_ARETE ", &
00332 "MED_NOEUD ", &
00333 "MED_NOEUD_MAILLE "/)
00334
00335 parameter (USER_MODE = MED_COMPACT )
00336
00337
00338
00339
00340
00341
00342 nbpdtnor=0;pflsize=0;ngauss=0;nval=0
00343 numdt = 0;numo=0;retmem=0
00344 cret=0;ret=0
00345
00346 nullify(type_geo)
00347 nullify(AFF)
00348
00349
00350 select case (entite)
00351 case (MED_NOEUD)
00352 type_geo => typ_noeud
00353 nb_geo = 1
00354 AFF => FMED_GEOMETRIE_NOEUD_AFF
00355 case (MED_MAILLE)
00356 type_geo => typmai
00357 nb_geo = MED_NBR_GEOMETRIE_MAILLE+2
00358 AFF => FMED_GEOMETRIE_MAILLE_AFF
00359 case (MED_NOEUD_MAILLE)
00360 type_geo => typmai
00361 nb_geo = MED_NBR_GEOMETRIE_MAILLE+2
00362 AFF => FMED_GEOMETRIE_MAILLE_AFF
00363 case (MED_FACE)
00364 type_geo => typfac;
00365 nb_geo = MED_NBR_GEOMETRIE_FACE+1
00366 AFF => FMED_GEOMETRIE_FACE_AFF
00367 case (MED_ARETE)
00368 type_geo => typare
00369 nb_geo = MED_NBR_GEOMETRIE_ARETE
00370 AFF => FMED_GEOMETRIE_ARETE_AFF
00371 end select
00372
00373 do k=1,nb_geo
00374
00375
00376 call efnpdt(fid,nomcha,entite,type_geo(k),nbpdtnor,ret)
00377 if (ret.ne.0) then
00378 print *, "Impossible de lire le nombre de pas de temps : " &
00379 & ,k,nomcha,entite,FMED_ENTITE_MAILLAGE_AFF(entite) &
00380 & ,type_geo(k),AFF(type_geo(k))
00381 cret = -1
00382 end if
00383 if(nbpdtnor < 1 ) continue
00384
00385 do j=1,nbpdtnor
00386
00387
00388 call efpdti(fid, nomcha, entite, type_geo(k), &
00389 & j, ngauss, numdt, numo, dt_unit, &
00390 & dt, maa_ass, local, nbrefmaa, ret )
00391 if (ret.ne.0) then
00392 print *, "Erreur a la demande d'information sur (pdt,nor) : " &
00393 & ,nomcha,entite, type_geo(k), ngauss, numdt, numo, dt_unit &
00394 & ,dt, maa_ass, local, nbrefmaa
00395 cret = -1
00396 end if
00397
00398 if (numdt .eq. MED_NOPDT) then
00399 write(*,'(5X,A)') 'Pas de pas de temps'
00400 else
00401 write(*,'(5X,A,I5,A,E20.8,A,A,A)') 'Pas de temps n° ' &
00402 & ,numdt,' (', dt ,') ', 'et d''unite ',TRIM(dt_unit)
00403 endif
00404 if (numo .eq. MED_NONOR) then
00405 write(*,'(5X,A)') 'Pas de numero d''ordre'
00406 else
00407 write(*,'(5X,A,I5)') 'Numero d ordre : ', numo
00408 endif
00409 write(*,'(5X,A,I5)') 'Nombre de points de gauss : ',ngauss
00410 write(*,'(5X,A,A)') 'Maillage associe : ', TRIM(maa_ass)
00411
00412
00413 if ( .not. local ) then
00414 call efnvli(fid,maa_ass,nvl,ret)
00415 if (ret.ne.0) then
00416 print *, "Erreur a la lecture de la taille du lien : " &
00417 & , maa_ass, local, nvl
00418 cret = -1
00419 end if
00420
00421 if (retmem .ne. 0) then
00422 print *, "Erreur a l'allocation mémoire de lien : "
00423 call efexit(-1)
00424 endif
00425 lien =""
00426 call efliel(fid,lien,nvl,maa_ass,ret)
00427 if (ret.ne.0) then
00428 print *,"Erreur a la lecture du lien : " &
00429 & ,maa_ass,lien
00430 cret = -1
00431 else
00432 write (*,'(5X,A,A,A,A,A)') 'Le maillage |',TRIM(maa_ass), &
00433 & '| est porte par un fichier distant |', &
00434 & TRIM(lien),'|'
00435 endif
00436
00437 endif
00438
00439
00440
00441
00442 call efnref(fid,nomcha,entite,type_geo(k),numdt,numo,nref,ret)
00443 if (ret.ne.0) then
00444 print *,"Erreur a la demande du nombre de maillages references par le champ : ", &
00445 & nomcha,numdt,numo
00446 cret = -1; continue
00447 endif
00448
00449 do l=1,nbrefmaa
00450
00451 call efrefi(fid,nomcha,entite,type_geo(k), &
00452 & l,numdt, numo, maa_ass, local, ngauss, ret)
00453 if (ret.ne.0) then
00454 print *,"Erreur a la demande d'information sur le maillage utilise par le champ n° : " &
00455 & ,nomcha,entite,type_geo(k), &
00456 & l,numdt, numo, maa_ass
00457 cret = -1; continue
00458 endif
00459
00460
00461 call efnval(fid,nomcha,entite,type_geo(k),numdt,numo,maa_ass,USER_MODE,nval,cret)
00462 if (ret.ne.0) then
00463 print *,"Erreur a la lecture du nombre de valeurs du champ : " &
00464 & ,nomcha,entite,type_geo(k), &
00465 & numdt, numo, maa_ass
00466 cret = -1; continue
00467 endif
00468 write(*,'(5X,A,I5,A,I5,A,A,A,A,A,A,A,I5,A)') &
00469 & 'Il y a ',nval,' valeurs en mode ',USER_MODE, &
00470 & ' . Chaque entite ',TRIM(FMED_ENTITE_MAILLAGE_AFF(entite)), &
00471 & ' de type geometrique ',TRIM(AFF(k)),' associes au maillage |',&
00472 & TRIM(maa_ass),'| a ',ngauss,' pts de gauss '
00473
00474
00475 if ( .not. local ) then
00476
00477 call efnvli(fid,maa_ass,nvl,ret)
00478 if (ret.ne.0) then
00479 print *, "Erreur a la lecture de la taille du lien : " &
00480 & , maa_ass, local, nvl
00481 cret = -1
00482 end if
00483
00484
00485 if (retmem .ne. 0) then
00486 print *, "Erreur a l'allocation mémoire de comp et unit : "
00487 call efexit(-1)
00488 endif
00489
00490 call efliel(fid,lien,nvl,maa_ass,ret)
00491 if (ret.ne.0) then
00492 print *,"Erreur a la lecture du lien : " &
00493 & ,maa_ass,lien
00494 cret = -1
00495 else
00496 write(*,'(5X,A,A,A,A,A)') 'Le maillage |',TRIM(maa_ass), &
00497 & '| est porte par un fichier distant |',TRIM(lien),'|'
00498 endif
00499
00500 endif
00501
00502
00503 if (typcha .eq. MED_FLOAT64) then
00504 allocate(valr(ncomp*nval),STAT=retmem)
00505
00506 call efchal(fid,maa_ass,nomcha,valr,stockage,MED_ALL,locname, &
00507 & pflname,USER_MODE,entite,type_geo(k),numdt,numo,ret)
00508
00509 if (ret.ne.0) then
00510 print *,"Erreur a la lecture du nombre de valeurs du champ : ", &
00511 & maa_ass,nomcha,valr,stockage,MED_ALL,locname, &
00512 & pflname,USER_MODE,entite,type_geo(k),numdt,numo
00513 cret = -1;
00514 endif
00515 else
00516 allocate(vale(ncomp*nval),STAT=retmem)
00517
00518 call efchal(fid,maa_ass,nomcha,vale,stockage,MED_ALL,locname, &
00519 & pflname,USER_MODE,entite,type_geo(k),numdt,numo,ret)
00520 if (ret.ne.0) then
00521 print *,"Erreur a la lecture des valeurs du champ : ",&
00522 & maa_ass,nomcha,vale,stockage,MED_ALL,locname, &
00523 & pflname,USER_MODE,entite,type_geo(k),numdt,numo
00524 cret = -1;
00525 endif
00526
00527 endif
00528
00529 if (ngauss .gt. 1 ) then
00530 write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
00531 & "points de Gauss de nom ", TRIM(locname)
00532 end if
00533
00534 if ( entite .eq. MED_NOEUD_MAILLE ) then
00535 ngroup = MOD(type_geo(k),100)
00536 else
00537 ngroup = ngauss
00538 end if
00539
00540 select case (stockage)
00541 case (MED_FULL_INTERLACE)
00542 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
00543 do m=0,(nval/ngroup-1)
00544 write(*,*) "|"
00545 do n=0,(ngroup*ncomp-1)
00546 if (typcha .eq. MED_FLOAT64) then
00547 write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
00548 else
00549 write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
00550 end if
00551 enddo
00552 enddo
00553 case (MED_NO_INTERLACE)
00554 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
00555 do m=0,ncomp-1
00556 write(*,*) "|"
00557 do n=0,nval-1
00558 if (typcha .eq. MED_FLOAT64) then
00559 write (*,'(1X,E20.5,1X)') valr(m*nval+n +1)
00560 else
00561 write (*,'(1X,I8,1X)') vale(m*nval+n +1)
00562 endif
00563 enddo
00564 enddo
00565 end select
00566
00567 write(*,*) "|"
00568 if (typcha .eq. MED_FLOAT64) then
00569 deallocate(valr)
00570 else
00571 deallocate(vale)
00572 endif
00573
00574
00575 if (pflname .eq. MED_NOPFL) then
00576 write(*,'(5X,A)') 'Pas de profil'
00577 else
00578 write(*,'(5X,A,A)') 'Profil :',pflname
00579 call efnpfl(fid,pflname,pflsize,ret)
00580 if (ret .ne. 0) then
00581 print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
00582 & pflname,pflsize
00583 cret = -1;continue
00584 endif
00585 write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
00586
00587
00588 allocate(pflval(pflsize),STAT=retmem)
00589 if (retmem .ne. 0) then
00590 print *, "Erreur a l'allocation mémoire de pflsize : "
00591 call efexit(-1)
00592 endif
00593
00594 call efpfll(fid,pflval,pflname,ret)
00595 if (cret .ne. 0) write(*,'(I1)') cret
00596 if (ret .ne. 0) then
00597 print *,"Erreur a la lecture du profil : ", &
00598 & pflname,pflval
00599 cret = -1;continue
00600 endif
00601 write(*,'(5X,A)') 'Valeurs du profil : '
00602 do m=1,pflsize
00603 write (*,'(5X,I6)') pflval(m)
00604 enddo
00605
00606 deallocate(pflval)
00607
00608 endif
00609
00610 enddo
00611
00612 enddo
00613
00614 enddo
00615
00616 print *,""
00617 getFieldsOn=ret
00618
00619 end function getFieldsOn