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.hf90'
00030
00031
00032 integer cret,ret,lret,retmem, fid
00033 integer USER_INTERLACE,USER_MODE
00034 character*64 :: 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 integer nstep, stype, atype,sdim
00048 character*16 nomcoo(3)
00049 character*16 unicoo(3)
00050 integer lmesh, ncst
00051 character*64 :: giname, isname
00052 integer nsmc, sgtype
00053
00054 parameter (USER_INTERLACE = MED_FULL_INTERLACE)
00055 parameter (USER_MODE = MED_COMPACT_PFLMODE)
00056
00057 cret=0;ret=0;lret=0;retmem=0
00058 print *,"Indiquez le fichier med a decrire : "
00059
00060 argc="test10.med"
00061
00062
00063 call mfiope(fid,argc,MED_ACC_RDONLY, ret)
00064 if (ret .ne. 0) call efexit(-1)
00065
00066
00067 if (ret.eq.0) then
00068 call mmhmii(fid,1,maa,sdim,mdim,type,desc,dtunit,stype,nstep,atype,nomcoo,unicoo,ret)
00069 endif
00070 if (ret.ne.0) then
00071 print *, "Erreur a la lecture des informations sur le maillage : ", &
00072 & maa,mdim,type,desc
00073 call efexit(-1)
00074 endif
00075
00076 write (*,'(/A,A,A,I1)') "Maillage de nom |",TRIM(maa),"| et de dimension ",mdim
00077
00078
00079 call mfdnfd(fid,ncha,ret)
00080 if (ret.ne.0) then
00081 print *, "Impossible de lire le nombre de champs : ",ncha
00082 call efexit(-1)
00083 endif
00084
00085 write (*,'(A,I1/)') "Nombre de champs : ",ncha
00086
00087
00088
00089 do i=1,ncha
00090 lret = 0
00091 write(*,'(A,I5)') "- Champ numero : ",i
00092
00093
00094 call mfdnfc(fid,i,ncomp,ret)
00095
00096 if (ret.ne.0) then
00097 print *, "Erreur a la lecture du nombre de composantes : ",ncomp
00098 cret = -1
00099 endif
00100
00101
00102 allocate(comp(ncomp),unit(ncomp),STAT=retmem)
00103 if (retmem .ne. 0) then
00104 print *, "Erreur a l'allocation mémoire de comp et unit : "
00105 call efexit(-1)
00106 endif
00107
00108
00109 call mfdfdi(fid,i,nomcha,maa,lmesh,typcha,comp,unit,dtunit,ncst,ret)
00110 if (ret .ne. 0) then
00111 print *, "Erreur a la demande d'information sur les champs : ",nomcha,typcha,comp,unit,ncomp,ncst
00112 cret = -1
00113 continue
00114 endif
00115
00116 write(*,'(/5X,A,A)') 'Nom du champ : ', TRIM(nomcha)
00117 write(*,'(/5X,A,A)') 'Nom du maillage : ',TRIM(maa)
00118 write(*,'(5X,A,I5)') 'Type du champ : ', typcha
00119 do j=1,ncomp
00120 write(*,'(5X,A,I1,A,A,A,A)') 'Composante ',j,' : ',TRIM(comp(j)),' ',TRIM(unit(j))
00121 enddo
00122 write(*,'(5X,A,I1)') 'Nombre de pas de temps = ',ncst
00123 print *,""
00124
00125 deallocate(comp,unit)
00126
00127 if ( (index(nomcha,"champ entier") .eq. 1) .and. &
00128 (len_trim(nomcha) .eq. len("champ entier") ) ) then
00129
00130 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE, USER_INTERLACE, ncst)
00131
00132
00133 if (lret .eq. 0) then
00134 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_CELL, USER_INTERLACE, ncst)
00135 else
00136 print *, "Erreur a la lecture des champs aux noeuds "; cret = -1; continue
00137 endif
00138
00139 if (lret .eq. 0) then
00140 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_FACE,USER_INTERLACE, ncst)
00141 else
00142 print *,"Erreur a la lecture des champs aux mailles "; cret = -1; continue
00143 endif
00144
00145 if (lret .eq. 0) then
00146 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_DESCENDING_EDGE,USER_INTERLACE, ncst)
00147 else
00148 print *,"Erreur a la lecture des champs aux faces "; cret = -1; continue
00149 endif
00150
00151 if (lret .eq. 0) then
00152 lret = getFieldsOn(fid, nomcha, typcha, ncomp, MED_NODE_ELEMENT,USER_INTERLACE, ncst)
00153 else
00154 print *,"Erreur a la lecture des champs aux aretes "; cret = -1; continue
00155 endif
00156
00157 if (lret .ne. 0) then
00158 print *,"Erreur a la lecture des champs aux noeuds des mailles "; cret = -1
00159 endif
00160 else
00161 print *, "There is no API yet for reading field on multiple meshes"
00162 endif
00163 enddo
00164
00165
00166 call mpfnpf(fid,nval,ret)
00167 write (*,'(5X,A,I2)') 'Nombre de profils stockés : ', nval
00168
00169 if (nval .gt. 0 ) then
00170 do i=1,nval
00171 call mpfpfi(fid,i,pflname,nval,ret)
00172 write (*,'(5X,A,I2,A,A,A,I2)') 'Profil n ',i,' : ',pflname, ' et de taille',nval
00173 enddo
00174 endif
00175
00176
00177
00178 call mlnnln(fid,nln,ret)
00179 if (ret.ne.0) then
00180 print *,"Erreur a la lecture du nombre de liens : " &
00181 & ,nln
00182 cret = -1;
00183 else
00184 print *,""
00185 write (*,'(5X,A,I5)') "Nombre de liens stockes : ",nln;print *,"";print *,""
00186 do i=1,nln
00187 call mlnlni(fid, i, nomlien, nval, ret)
00188 if (ret.ne.0) then
00189 print *,"Erreur a la demande d'information sur le lien n° : ",i
00190 cret = -1;continue;
00191 endif
00192 write (*,'(5X,A,I4,A,A,A,I4)') "- Lien n°",i," de nom |",TRIM(nomlien),"| et de taille ",nval
00193
00194 lien = ""
00195 call mlnlir(fid,nomlien,lien,ret)
00196 if (ret.ne.0) then
00197 print *,"Erreur a la lecture du lien : ", lien,nval,nomlien
00198 ret = -1;
00199 else
00200 write (*,'(5X,A,A,A)') "|",TRIM(lien),"|";print *,"";print *,""
00201 endif
00202
00203 end do
00204 endif
00205
00206
00207
00208 call mlcnlc(fid,nloc,ret)
00209 if (ret.ne.0) then
00210 print *,"Erreur a la lecture du nombre de points de Gauss : " &
00211 & ,nloc
00212 cret = -1;
00213 else
00214 print *,"Nombre de localisations stockees : ",nloc;print *,"";print *,""
00215 do i=1,nloc
00216 call mlclci(fid, i, locname, type_geo, sdim, ngauss, giname, isname, nsmc, sgtype, ret)
00217 if (ret.ne.0) then
00218 print *,"Erreur a la demande d'information sur la localisation n° : ",i
00219 cret = -1;continue;
00220 endif
00221 write (*,'(5X,A,I4,A,A,A,I4,A,I4)') "- Loc n°",i," de nom |",TRIM(locname) &
00222 &,"| et nbr. de pts Gauss ",ngauss,"| et dans un espace de dimension ",sdim
00223 t1 = MOD(type_geo,100)*sdim
00224 t2 = ngauss*sdim
00225 t3 = ngauss
00226 allocate(refcoo(t1),STAT=retmem)
00227 if (retmem .ne. 0) then
00228 print *, "Erreur a l'allocation mémoire de refcoo : "
00229 call efexit(-1)
00230 endif;
00231 allocate(gscoo(t2),STAT=retmem)
00232 if (retmem .ne. 0) then
00233 print *, "Erreur a l'allocation mémoire de gscoo : "
00234 call efexit(-1)
00235 endif;
00236 allocate(wg(t3),STAT=retmem)
00237 if (retmem .ne. 0) then
00238 print *, "Erreur a l'allocation mémoire de wg : "
00239 call efexit(-1)
00240 endif;
00241 call mlclor(fid, locname,USER_INTERLACE,refcoo,gscoo,wg, ret )
00242 if (ret.ne.0) then
00243 print *,"Erreur a la lecture des valeurs de la localisation : " &
00244 & ,locname
00245 cret = -1;
00246 else
00247 write (*,'(5X,A,I4)') "Coordonnees de l'element de reference de type ",type_geo
00248 do j=1,t1
00249 write (*,'(5X,E20.8)') refcoo(j)
00250 enddo
00251 print *,""
00252 write (*,'(5X,A)') "Localisation des points de GAUSS : "
00253 do j=1,t2
00254 write (*,'(5X,E20.8)') gscoo(j)
00255 enddo
00256 print *,""
00257 write (*,'(5X,A)') "Poids associes aux points de GAUSS "
00258 do j=1,t3
00259 write (*,'(5X,E20.8)') wg(j)
00260 enddo
00261 print *,""
00262 endif
00263 deallocate(refcoo)
00264 deallocate(gscoo)
00265 deallocate(wg)
00266 enddo
00267 endif
00268
00269 call mficlo(fid,ret)
00270
00271
00272 call efexit(cret)
00273
00274 end program test11
00275
00276
00277 integer function getFieldsOn(fid, nomcha, typcha, ncomp, entite, stockage, ncst)
00278 implicit none
00279 include 'med.hf90'
00280
00281 integer ::fid,typcha,ncomp,entite,stockage, ncst
00282 character(LEN=*) nomcha
00283
00284 integer :: j,k,l,m,n,nb_geo,cret,ret,retmem,nvl,nref
00285 integer :: nbpdtnor,pflsize,ngauss,ngroup,nent,nprofile
00286 integer, allocatable, dimension(:) :: pflval
00287 integer, allocatable, dimension(:) :: vale
00288 integer :: numdt,numo,lnsize,nbrefmaa
00289 real*8, allocatable, dimension(:) :: valr
00290 real*8 dt
00291 logical local
00292 character*64 :: pflname,locname,maa_ass
00293 character*16 :: dt_unit
00294 character*255:: lien
00295 integer USER_MODE
00296
00297 integer,pointer,dimension(:) :: type_geo
00298 integer,target :: typ_noeud(1) = (/ MED_NONE /)
00299
00300 integer :: MY_NOF_CELL_TYPE = 17
00301 integer :: MY_NOF_DESCENDING_FACE_TYPE = 5
00302 integer :: MY_NOF_DESCENDING_EDGE_TYPE = 2
00303
00304 integer,target :: typmai(17) = (/ MED_POINT1,MED_SEG2,
00305 MED_SEG3,MED_TRIA3, &
00306 MED_QUAD4,MED_TRIA6, &
00307 MED_QUAD8,MED_TETRA4, &
00308 MED_PYRA5,MED_PENTA6, &
00309 MED_HEXA8,MED_TETRA10, &
00310 MED_PYRA13,MED_PENTA15, &
00311 MED_HEXA20,MED_POLYGON,&
00312 MED_POLYHEDRON/)
00313
00314 integer,target :: typfac(5) = (/MED_TRIA3,MED_TRIA6,
00315 MED_QUAD4,MED_QUAD8,MED_POLYGON/)
00316 integer,target ::typare(2) = (/MED_SEG2,MED_SEG3/)
00317
00318 character(LEN=15),pointer,dimension(:) :: AFF
00319 character(LEN=15),target,dimension(17) :: FMED_GEOMETRIE_MAILLE_AFF = (/
00320 "MED_POINT1 ",&
00321 "MED_SEG2 ",&
00322 "MED_SEG3 ",&
00323 "MED_TRIA3 ",&
00324 "MED_QUAD4 ",&
00325 "MED_TRIA6 ",&
00326 "MED_QUAD8 ",&
00327 "MED_TETRA4 ",&
00328 "MED_PYRA5 ",&
00329 "MED_PENTA6 ",&
00330 "MED_HEXA8 ",&
00331 "MED_TETRA10 ",&
00332 "MED_PYRA13 ",&
00333 "MED_PENTA15 ",&
00334 "MED_HEXA20 ",&
00335 "MED_POLYGON ",&
00336 "MED_POLYHEDRON " /)
00337
00338 character(LEN=15),target,dimension(5) :: FMED_GEOMETRIE_FACE_AFF = (/
00339 "MED_TRIA3 ",&
00340 "MED_TRIA6 ",&
00341 "MED_QUAD4 ",&
00342 "MED_QUAD8 ",&
00343 "MED_POLYGON " /)
00344
00345 character(LEN=15),target,dimension(2) :: FMED_GEOMETRIE_ARETE_AFF = (/
00346 "MED_SEG2 ",&
00347 "MED_SEG3 " /)
00348
00349 character(LEN=15),target,dimension(1) :: FMED_GEOMETRIE_NOEUD_AFF = (/
00350 "(AUCUN) "/)
00351
00352
00353 character(LEN=20),target,dimension(0:4) :: FMED_ENTITE_MAILLAGE_AFF =(/
00354 "MED_CELL ", &
00355 "MED_DESCENDING_FACE ", &
00356 "MED_DESCENDING_EDGE ", &
00357 "MED_NODE ", &
00358 "MED_NODE_ELEMENT "/)
00359
00360 parameter (USER_MODE = MED_COMPACT_PFLMODE )
00361
00362
00363
00364
00365
00366
00367 locname=''
00368 nbpdtnor=0;pflsize=0;ngauss=0;nent=0
00369 numdt = 0;numo=0;retmem=0
00370 cret=0;ret=0
00371
00372 nullify(type_geo)
00373 nullify(AFF)
00374
00375
00376 select case (entite)
00377 case (MED_NODE)
00378 type_geo => typ_noeud
00379 nb_geo = 1
00380 AFF => FMED_GEOMETRIE_NOEUD_AFF
00381 case (MED_CELL)
00382 type_geo => typmai
00383 nb_geo = 17
00384 AFF => FMED_GEOMETRIE_MAILLE_AFF
00385 case (MED_NODE_ELEMENT)
00386 type_geo => typmai
00387 nb_geo = 17
00388 AFF => FMED_GEOMETRIE_MAILLE_AFF
00389 case (MED_DESCENDING_FACE)
00390 type_geo => typfac;
00391 nb_geo = 5
00392 AFF => FMED_GEOMETRIE_FACE_AFF
00393 case (MED_DESCENDING_EDGE)
00394 type_geo => typare
00395 nb_geo = MY_NOF_DESCENDING_EDGE_TYPE
00396 AFF => FMED_GEOMETRIE_ARETE_AFF
00397 end select
00398
00399 do k=1,nb_geo
00400
00401
00402 nbpdtnor = ncst
00403 if(nbpdtnor < 1 ) continue
00404
00405 do j=1,ncst
00406
00407 call mfdcsi(fid,nomcha,j,numdt,numo,dt,ret)
00408
00409 if (ret.ne.0) then
00410 print *, "Erreur a la demande d'information sur (pdt,nor) : " &
00411 & ,nomcha,entite, numdt, numo, dt
00412 cret = -1
00413 end if
00414
00415 call mfdnpf(fid,nomcha,numdt,numo,entite,type_geo(k),pflname,locname,nprofile,ret)
00416
00417 if (ret.ne.0) then
00418 print *, "Erreur a la lecture du nombre de profil : " &
00419 & ,nomcha,entite, type_geo(k),numdt, numo
00420 cret = -1
00421 call efexit(cret)
00422 end if
00423
00424 do l=1,nprofile
00425
00426
00427 call mfdnvp(fid,nomcha,numdt,numo,entite,type_geo(k),l,USER_MODE,pflname,pflsize,locname,ngauss,nent,ret)
00428
00429 if (ret.ne.0) then
00430 print *,"Erreur a la lecture du nombre de valeurs du champ : " &
00431 & ,nomcha,entite,type_geo(k), &
00432 & numdt, numo
00433 cret = -1; continue
00434 endif
00435
00436
00437 write(*,'(5X,A,I2,A,I2,A,I2,A,E10.5,A)') 'Séquence de calcul n° ',l,' (',numdt,',',numo,'), dt=(',dt,')'
00438 write(*,'(5X,A,I5,A,I2,A,A,A,A,A,A,I2,A,A)') &
00439 & 'Il y a ',nent,' valeurs en mode ',USER_MODE, &
00440 & '. Chaque entite ',TRIM(FMED_ENTITE_MAILLAGE_AFF(entite)), &
00441 & ' de type geometrique ',TRIM(AFF(k)),' associes au profil |',&
00442 & TRIM(pflname)//'| a ',ngauss,' valeur(s) par entité, et une localization de nom |',TRIM(locname)//'|'
00443
00444
00445 if (typcha .eq. MED_FLOAT64) then
00446 allocate(valr(ncomp*nent*ngauss),STAT=retmem)
00447
00448 call mfdrpr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
00449 & pflname,stockage,MED_ALL_CONSTITUENT,valr,ret)
00450
00451 if (ret.ne.0) then
00452 print *,"Erreur a la lecture des valeurs du champ : ", &
00453 & nomcha,valr,stockage,MED_ALL_CONSTITUENT, &
00454 & pflname,USER_MODE,entite,type_geo(k),numdt,numo
00455 cret = -1;
00456 call efexit(cret)
00457 endif
00458 else
00459 allocate(vale(ncomp*nent*ngauss),STAT=retmem)
00460
00461 call mfdipr(fid,nomcha,numdt,numo,entite,type_geo(k),USER_MODE, &
00462 & pflname,stockage,MED_ALL_CONSTITUENT,vale,ret)
00463
00464 if (ret.ne.0) then
00465 print *,"Erreur a la lecture des valeurs du champ : ",&
00466 & nomcha,vale,stockage,MED_ALL_CONSTITUENT, &
00467 & pflname,USER_MODE,entite,type_geo(k),numdt,numo
00468 cret = -1;
00469 endif
00470
00471 endif
00472
00473 if (ngauss .gt. 1 ) then
00474 write (*,'(5X,A,A,A)') "- Modèle de localisation des ", &
00475 & "points de Gauss de nom ", TRIM(locname)
00476 end if
00477
00478 if ( entite .eq. MED_NODE_ELEMENT ) then
00479 ngroup = MOD(type_geo(k),100)
00480 else
00481 ngroup = ngauss
00482 end if
00483
00484 select case (stockage)
00485 case (MED_FULL_INTERLACE)
00486 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
00487 do m=0,nent-1
00488 write(*,*) "|"
00489 do n=0,(ngroup*ncomp-1)
00490 if (typcha .eq. MED_FLOAT64) then
00491 write (*,'(1X,E20.5,1X)') valr( m*ngroup*ncomp+n +1 )
00492 else
00493 write (*,'(1X,I8,1X)') vale( m*ngroup*ncomp+n +1 )
00494 end if
00495 enddo
00496 enddo
00497 case (MED_NO_INTERLACE)
00498 write(*,'(5X,A)') "- Valeurs :"; write(*,'(5X,A)') ""
00499 do m=0,ncomp-1
00500 write(*,*) "|"
00501 do n=0,nent-1
00502 if (typcha .eq. MED_FLOAT64) then
00503 write (*,'(1X,E20.5,1X)') valr(m*nent+n +1)
00504 else
00505 write (*,'(1X,I8,1X)') vale(m*nent+n +1)
00506 endif
00507 enddo
00508 enddo
00509 end select
00510
00511 write(*,*) "|"
00512 if (typcha .eq. MED_FLOAT64) then
00513 deallocate(valr)
00514 else
00515 deallocate(vale)
00516 endif
00517
00518
00519 if (pflname .eq. MED_NO_PROFILE) then
00520
00521 else
00522 write(*,'(5X,A,A)') 'Profil :',pflname
00523 call mpfpsn(fid,pflname,pflsize,ret)
00524 if (ret .ne. 0) then
00525 print *,"Erreur a la lecture du nombre de valeurs du profil : ", &
00526 & pflname,pflsize
00527 cret = -1;continue
00528 endif
00529 write(*,'(5X,A,I5)') 'Taille du profil : ',pflsize
00530
00531
00532 allocate(pflval(pflsize),STAT=retmem)
00533 if (retmem .ne. 0) then
00534 print *, "Erreur a l'allocation mémoire de pflsize : "
00535 call efexit(-1)
00536 endif
00537
00538 call mpfprr(fid,pflname,pflval,ret)
00539 if (cret .ne. 0) write(*,'(I1)') cret
00540 if (ret .ne. 0) then
00541 print *,"Erreur a la lecture du profil : ", &
00542 & pflname,pflval
00543 cret = -1;continue
00544 endif
00545 write(*,'(5X,A)') 'Valeurs du profil : '
00546 do m=1,pflsize
00547 write (*,'(5X,I6)') pflval(m)
00548 enddo
00549
00550 deallocate(pflval)
00551
00552 endif
00553
00554 enddo
00555
00556 enddo
00557
00558 enddo
00559
00560 print *,""
00561 getFieldsOn=ret
00562
00563 end function getFieldsOn