1 : C MEDR SOURCE PASCAL 12/06/18 21:15:05 7403 2 : subroutine medr 3 : implicit integer(i-n) 4 : implicit real*8(a-h,o-z) 5 : * opérateur med_restitution 6 : -INC CCOPTIO 7 : -INC SMELEME 8 : -INC SMCOORD 9 : -INC SMLMOTS 10 : -INC CCGEOME 11 : -INC SMTABLE 12 : -INC SMCHPOI 13 : * parameter (MED_LECTURE=0,MED_LECTURE_ECRITURE=1) 14 : * parameter (MED_LECTURE_AJOUT=2,MED_CREATION=3) 15 : * parameter (MED_FULL_INTERLACE=0, MED_NO_INTERLACE=1) 16 : * parameter (MED_NON_STRUCTURE=0,MED_STRUCTURE=1) 17 : * parameter (MED_GRILLE_CARTESIENNE=0,MED_GRILLE_POLAIRE=1) 18 : * parameter (MED_GRILLE_STANDARD=2) 19 : parameter (MED_MAILLE=0,MED_FACE=1,MED_ARETE=2,MED_NOEUD=3) 20 : * parameter (MED_POINT1=1,MED_SEG2=102,MED_SEG3=103,MED_TRIA3=203) 21 : * parameter (MED_TRIA6=206,MED_QUAD4=204,MED_QUAD8=208) 22 : * parameter (MED_TETRA4=304,MED_TETRA10=310,MED_HEXA8=308) 23 : * parameter (MED_HEXA20=320,MED_PENTA6=306) 24 : * parameter (MED_PENTA15=315,MED_PYRA5=305,MED_PYRA13=313) 25 : * parameter (MED_POLYGONE = 400, MED_POLYEDRE = 500, MED_NONE=0) 26 : * parameter (MED_NBR_GEOMETRIE_MAILLE = 15,MED_NBR_GEOMETRIE_FACE=4) 27 : * parameter (MED_NBR_GEOMETRIE_ARETE = 2) 28 : * parameter (MED_COOR=0,MED_CONN=1,MED_NOM=2,MED_NUM=3,MED_FAM=4) 29 : * parameter (MED_COOR_IND1=5,MED_COOR_IND2=6,MED_COOR_IND3=7) 30 : * parameter (MED_NOD=0, MED_DESC=1) 31 : * parameter (MED_CART=0,MED_CYL=1, MED_SPHER=2) 32 : * parameter (MED_INT32=24, MED_INT64=26,MED_FLOAT64=6) 33 : * parameter (MED_NOPG = 1) 34 : * character*32 MED_NOGAUSS 35 : * parameter (MED_NOGAUSS=' ') 36 : * character*32 MED_GAUSS_ELNO 37 : * parameter (MED_GAUSS_ELNO='MED_GAUSS_ELNO ') 38 : * parameter (MED_NOPF = 0) 39 : * character*32 MED_NOPFL 40 : * parameter (MED_NOPFL=' ') 41 : * parameter (MED_NONOR = -1) 42 : * parameter (MED_NONOR = -1) 43 : * parameter (MED_ALL = 0) 44 : parameter (MED_NO_PFLMOD=0, MED_GLOBAL=1, MED_COMPACT=2) 45 : * parameter (MED_MAILLAGE= 0) 46 : * parameter (MED_CHAMP= 1) 47 : character*72 cha72 48 : character*8 cha8 49 : character*32 NOMMAA,NOMFA,cha32,chb32,NOMMAP 50 : character*200 DESMAA 51 : character*48 COMP,UNIT 52 : character*8 nompoint 53 : logical bnoel,bnuel 54 : logical ltelq 55 : segment maitot 56 : integer ipomai(15),inumli(15) 57 : endsegment 58 : segment ijfam 59 : Integer infaa(infam),inogro(infam) 60 : character*32 nomfam(infam) 61 : endsegment 62 : segment iclame 63 : integer icla(320),itab(15) 64 : endsegment 65 : segment icoor 66 : real*8 xcoo(isdim,nbpta) 67 : endsegment 68 : * segment car128 69 : character*16 icar(1000) 70 : * endsegment 71 : segment numele 72 : integer nume(INBELE) 73 : endsegment 74 : segment att 75 : integer attr(INBATT) 76 : integer attr2(INBATT) 77 : character*200 attr3(INBATT) 78 : endsegment 79 : segment lisnog 80 : character*32 lisno(jg) 81 : endsegment 82 : segment nomg32 83 : character*80 nogr32(kg) 84 : endsegment 85 : external long 86 : segment numlis(INBELE) 87 : segment nomnoe(nbpta) 88 : segment numfampt(NBFAMPT) 89 : CHARACTER*26 MINU,MAJU 90 : character*72 medres 91 : DATA MINU/'abcdefghijklmnopqrstuvwxyz'/ 92 : DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ 93 : segini iclame 94 : icla(1)=1 95 : icla(102)=2 96 : icla(103 )=3 97 : icla(203 )=4 98 : icla(206 )=6 99 : icla(204 )=8 100 : icla(208 )=10 101 : icla(308 )=14 102 : icla(320 )=15 103 : icla(306 )=16 104 : icla(315 )=17 105 : icla(304 )=23 106 : icla(310 )=24 107 : icla(305 )=25 108 : icla(313 )=26 109 : itab(1)=1 110 : itab(2)=102 111 : itab(3)=103 112 : itab(4)=203 113 : itab(5)=206 114 : itab(6)=204 115 : itab(7)=208 116 : itab(8)=308 117 : itab(9)=320 118 : itab(10)=306 119 : itab(11)=315 120 : itab(12)=304 121 : itab(13)=310 122 : itab(14)=305 123 : itab(15)=313 124 : nbnoin= xcoor(/1)/(idim+1) 125 : ndecco=xcoor(/1) 126 : * write(6,*) ' ndecco ' , ndecco 127 : ltelq=.TRUE. 128 : nbref=0 129 : nbsous=0 129 : call lircha(medres,1,iretou) 130 : if(ierr.ne.0) return 130 : call lircha(cha32,0,iretou) 131 : if(ierr.ne.0) return 132 : if (iretou.eq.0) cha32=' ' 133 : * SP : MLMOTS ???? 133 : call lirobj('MLMOTS',mlmot1,0,iretou) 134 : if(iretou.ne.0) then 134 : call lirobj('MLMOTS',mlmot2,1,iretou) 135 : if(ierr.ne.0) return 136 : segact mlmot1,mlmot2 137 : if(mlmot1.mots(/2).ne.mlmot2.mots(/2)) then 137 : call erreur(19) 138 : return 139 : endif 140 : endif 141 : * 142 : * ici il faut lire 143 : * 144 : iloh=long(medres) 144 : call EFOUVR4(ifid,medres(1:iloh),0,ICRET) 144 : if(icret.ne.0) call efexit4(-1) 145 : nommap=' ' 146 : do i=1,100 147 : nommaa=' ' 147 : call EFMAAI4(IFID,i,NOMMAA,ISDIM,ITYPEM,DESMAA,ICRET) 148 : if(NOMMAA.eq.cha32.and.cha32.ne.' ') goto 100 149 : if(nommaa.ne.' ') then 150 : if (NOMMAA.eq.nommap) goto 99 151 : write(ioimp,*) 152 : $ 'objet existant dans le fichier : ' , nommaa 153 : endif 154 : nommap=nommaa 155 : enddo 156 : 99 continue 157 : return 158 : 159 : 100 continue 160 : *0 = MED_COOR 3 = MED_NOEUD 160 : call EFNEMA4(IFID,NOMMAA,0,3,0,0,nbpta,ICRET) 161 : if(icret.ne.0) then 162 : * write (6,*) ' plouf efnema -1' 162 : call efexit4(-1) 163 : return 164 : endif 165 : * write(6,*) ' nbpta ' , nbpta 166 : nbpts=nbpta +nbnoin 167 : segadj mcoord 168 : segini icoor 169 : *0 = MED_FULL_INTERLACE 0=MED_ALL 170 : * write(6,*) ' appel à efcool' 170 : call EFCOOL4(IFID,NOMMAA,ISDIM,xcoo(1,1),0,0,0,0,IREPER,COMP 171 : & ,UNIT, ICRET,0,0) 172 : * write(6,*) ' sortie de efcool' 173 : if(icret.ne.0) then 174 : * write(6,*) ' plouf efcool 0' 174 : call efexit4(-1) 175 : return 176 : endif 177 : if(idim.lt.isdim) then 178 : iidim=idim 179 : idim=isdim 180 : segadj mcoord 181 : if(nbnoin.ne.0) then 182 : do iou=1,nbnoin 183 : nint1=(nbnoin+1-iou)*(idim+1) 184 : nint2=(nbnoin+1-iou)*(iidim+1) 185 : xcoor( nint1) =xcoor(nint2) 186 : do iau=1,iidim 187 : xcoor(nint1-idim-1+iau)=xcoor(nint2-iidim-1+iau) 188 : enddo 189 : enddo 190 : endif 191 : endif 192 : * write(6,*) ' nbpta isdim idim ' , nbpta,isdim,idim 193 : do iou=1,nbpta 194 : do jou=1,isdim 195 : xcoor(ndecco+jou+(iou-1)*(idim+1))=xcoo(jou,iou) 196 : enddo 197 : enddo 198 : * write(6,*) ' sortie de boucle iou jou ' 199 : segsup icoor 200 : * write(6,*) ' sortie de segsup icoor ' 201 : iffa=0 202 : * write(6,*) ' avant segini maitot' 203 : segini maitot 204 : * write(6,*) ' apres segini maitot' 205 : * o, nomme le maillage complet 206 : nbref=0 207 : nbsous=15 208 : nbelem=0 209 : nbnn=0 210 : segini ipt1 211 : DO ITYPEM=1,15 212 : *MED_CONN=1 MED_NOD=0, MED_MAILLE=0 213 : * write(6,*) ' appel a efnema itypem ',itypem 213 : call EFNEMA4(IFID,NOMMAA,1,0,ITAB(ITYPEM),0,inbele,ICRET) 214 : * write(6,*) ' sortie a efnema inbele' , inbele, nommaa 215 : if(icret.ne.0) then 216 : * write(6,*) ' plouf 1' 216 : call efexit4(-1) 217 : return 218 : endif 219 : if(INBELE.ne.0) then 220 : * write(6,*) ' itypem inbele ' ,itypem, inbele 221 : iffa=iffa+1 222 : nbelem=inbele 223 : nbnn=nbnne(icla(itab(itypem))) 224 : * write(6,*) ' icla(itab(itypem)) ', icla(itab(itypem)) 225 : * write(6,*) 'nbnn ' , nbnn 226 : * write(6,*) 'itype ' , ITAB(ITYPEM) 227 : nbsous=0 228 : nbref=0 229 : segini meleme 230 : ipt1.lisous(iffa)=meleme 231 : * segini car128 232 : segini numele 233 : segini numlis 234 : ipomai(iffa)=meleme 235 : inumli(iffa)=numlis 235 : * CALL EFELEL(IFID,NOMMAA,ISDIM,num,0,icar(1),BNOEL, 236 : * & , nume(1),BNUEL,numlis(1),INBELE,0,ITAB(ITYPEM),0, 237 : * & ICRET) 238 : nva0=num(/1)*num(/2) 238 : * CALL EFCONL(IFID,NOMMAA,ISDIM,num,0,0,0,0,ITAB(ITYPEM),0, 239 : * & ICREt) 239 : CALL EFCONL4(IFID,NOMMAA,ISDIM,num,0,0,0,0,ITAB(ITYPEM),0, 240 : & ICRET,num,nva0,0,0) 240 : * CALL EFFAML(IFID,NOMMAA,numlis(1),inbele,0,ITAB(ITYPEM), 241 : * & ICRET) 241 : CALL EFFAML4(IFID,NOMMAA,numlis(1),inbele,0,ITAB(ITYPEM), 242 : & ICRET,numlis(1)) 243 : * write(6,*) ' num',(( num(ik,j),ik=1,nbnn),j=1,inbele) 244 : do iyp=1,inbele 245 : icolor(iyp)=idcoul 246 : enddo 247 : * write(6,*) ' numlis',(numlis(j),j=1,inbele) 248 : * segsup car128,numele 249 : if(nbnoin.ne.0) then 250 : do iou=1,nbelem 251 : do jou=1,nbnn 252 : num(jou,iou)=num(jou,iou)+nbnoin 253 : enddo 254 : icolor(iou)=idcoul 255 : enddo 256 : endif 257 : itypel=icla(itab(itypem)) 257 : call medtra(meleme,2) 258 : ipomai(iffa)=meleme 259 : ipt1.lisous(iffa)=meleme 260 : endif 261 : ENDDO 262 : nbsous=iffa 263 : nbref=0 264 : nbnn=0 265 : nbref=0 266 : segadj ipt1 267 : segdes ipt1 268 : cha8=nommaa 269 : do iaux=1,8 270 : IRAL=INDEX(MINU,cha8(IAUX:IAUX)) 271 : IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) 272 : enddo 272 : call nomobj('MAILLAGE', cha8 , ipt1 ) 273 : * lecture des familles 274 : segini nomnoe 275 : * write(6,*) ' appel a effaml' 275 : CALL EFFAML4(IFID,NOMMAA,nomnoe(1),nbpta,3,0, 276 : & ICRET,nomnoe(1)) 277 : * write(6,*) ' sortie a effaml nbpta ', nbpta 278 : if(icret.ne.0) then 279 : * write(6,*) ' plouf 2' 279 : call efexit4(-1) 280 : return 281 : endif 282 : NBFAMPT = 0 283 : * write(6,*) ' nomnoe ' , (nomnoe(iyt),iyt=1,nbpta) 284 : * DO IOU=1,nbpta 285 : * IF(nomnoe(IOU).ne.0) then 286 : * NBFAMPT = NBFAMPT+1 287 : * endif 288 : * enddo 289 : * write(6,*)' nbfampt ', nbfampt 290 : * segini numfampt 291 : 292 : * write(6,*) ' appel a efnfam' 292 : CALL EFNFAM4(IFID,NOMMAA,INFAM,ICRET) 293 : * write(6,*) ' sortie a efnfam infam ', infam 294 : segini ijfam 295 : * write(6,*) ' infam ' , infam 296 : DO IFAM=1,INFAM 296 : CALL EFNGRO4(IFID,NOMMAA,IFAM,kg,ICRET) 296 : CALL EFNATT4(IFID,NOMMAA,IFAM,INBATT,ICRET) 297 : * write(6,*) ' inbatt ' , inbatt 298 : segini att 299 : segini nomg32 300 : * write(6,*) ' appel effami inbatt kg ' ,inbatt,kg 300 : CALL EFFAMI4(IFID,NOMMAA,IFAM,NOMFA,INUMFA,attr,attr2, 301 : & attr3,INBATT,nogr32,kg,ICRET,attr,attr2) 302 : * if (INUMFA.lt.0) then 303 : * numfampt(-INUMFA)=IFAM 304 : * endif 305 : segsup att 306 : infaa(ifam)=INUMFA 307 : inogro(ifam)=nomg32 308 : nomfam(ifam)=NOMFA 309 : * write(6,*) 'ifam infaa inogro nomfam',ifam, inumfa,nomg32,NOMFA 310 : * write(6,*) ' nogr32 ' , ( nogr32(iyu),iyu=1,nogr32(/2)) 311 : ENDDO 312 : * DO IOU=1,nbpta 313 : * IF (nomnoe(IOU).ne.0) then 314 : * ilocf=numfampt(-nomnoe(IOU)) 315 : * nompoint=nomfam(ilocf) 315 : * CALL NOMOBJ('POINT',nompoint,IOU+ndecco) 316 : * ENDIF 317 : * ENDDO 318 : * segsup numfampt 319 : 320 : segsup iclame 321 : 322 : * 323 : * creation de familles 324 : * 325 : nbref=0 326 : nbsous=0 327 : ipt3=0 328 : do 104 iou=1,infam 329 : * write(6,*) ' boucle 104 iou iffa' , iou,iffa 330 : ipt3=0 331 : inufam=infaa(iou) 332 : do 105 jou=1,iffa 333 : * write(6,*) ' boucle 105 jou' , jou 334 : numlis=inumli(jou) 335 : nbelem=0 336 : do kou=1,numlis(/1) 337 : if(numlis(kou).eq.inufam) nbelem=nbelem+1 338 : enddo 339 : if(nbelem.eq.0) go to 105 340 : ipt1=ipomai(jou) 341 : nbnn=ipt1.num(/1) 342 : mmm= ipt1.num(/2) 343 : * write(6,*) ' dim ipt1 nbnn nbelem ' , nbnn,mmm 344 : segini ipt2 345 : iel=0 346 : ipt2.itypel=ipt1.itypel 347 : do kou=1,numlis(/1) 348 : if(numlis(kou).eq.inufam) then 349 : iel=iel+1 350 : do mou=1,nbnn 351 : ipt2.num(mou,iel)=ipt1.num(mou,kou) 352 : enddo 353 : ipt2.icolor(iel)=idcoul 354 : endif 355 : enddo 356 : if(ipt3.eq.0) then 357 : ipt3=ipt2 358 : else 359 : * write(6,*) ' appel fuse ipt3,ipt2',ipt3,ipt2 359 : call fuse(ipt3,ipt2,ipt4,ltelq) 360 : ipt3=ipt4 361 : endif 362 : 105 continue 363 : nbpo=0 364 : do iyt=1,nomnoe(/1) 365 : if( nomnoe(iyt).eq.inufam) nbpo=nbpo+1 366 : enddo 367 : if( nbpo.ne.0) then 368 : nbnn=1 369 : nbelem=nbpo 370 : segini ipt2 371 : iuy=0 372 : ipt2.itypel=1 373 : do iyt=1,nomnoe(/1) 374 : if(nomnoe(iyt).eq.inufam) then 375 : iuy=iuy+1 376 : ipt2.num(1,iuy)=iyt+nbnoin 377 : ipt2.icolor(iuy)=idcoul 378 : endif 379 : enddo 380 : if( ipt3.eq.0) then 381 : ipt3=ipt2 382 : else 382 : call fuse(ipt3,ipt2,ipt4,ltelq) 383 : ipt3=ipt4 384 : endif 385 : endif 386 : infaa(iou)=ipt3 387 : * write(6,*) 'infaa de = ', iou , ipt3 388 : * faut-il nommer la famille? 389 : if(mlmot1.ne.0) then 390 : cha32=nomfam(iou) 391 : do mou=1,mlmot1.mots(/2) 392 : if(mlmot1.mots(mou).eq.cha32) then 393 : cha8=mlmot2.mots(mou) 394 : do iaux=1,8 395 : IRAL=INDEX(MINU,cha8(IAUX:IAUX)) 396 : IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) 397 : enddo 397 : call nomobj('MAILLAGE',cha8,ipt3) 398 : * write(6,*) ' affectationdufamille ' , cha8,ipt3 398 : * call ecmail( ipt3,0) 399 : go to 104 400 : endif 401 : enddo 402 : endif 403 : 104 continue 404 : * 405 : * fabrication des groupes 406 : * 407 : * on fabrique d'abord la liste de noms de groupe 408 : lnomg=0 409 : jg=10 410 : segini lisnog 411 : do 110 iou=1,infam 412 : nomg32=inogro(iou) 413 : do 111 jou=1,nogr32(/2) 414 : cha32=nogr32(jou) 415 : do kou=1,lnomg 416 : if(lisno(kou).eq.cha32) go to 111 417 : enddo 418 : lnomg=lnomg+1 419 : if(lnomg.gt.jg) then 420 : jg=jg+20 421 : segadj lisnog 422 : endif 423 : lisno(lnomg)=cha32 424 : 111 continue 425 : 110 continue 426 : * 427 : *allons-y groupe par groupe 428 : * 429 : do iou=1,lnomg 430 : cha32=lisno(iou) 431 : ipt3=0 432 : * write(6,*) ' groupe numero ',iou, ' de nom : ' , cha32 433 : do 115 jou=1,infam 434 : nomg32=inogro(jou) 435 : * write(6,*) ' nogr32(/2) ' , nogr32(/2) 436 : do kou=1,nogr32(/2) 437 : * write(6,*)cha32,nogr32(kou)(1:32) 438 : if(cha32.eq.nogr32(kou)(1:32))then 439 : * write(6,*) ' on a egalité' 440 : if(ipt3.eq.0)then 441 : ipt3=infaa(jou) 442 : else 443 : ipt2=infaa(jou) 443 : call fuse(ipt3,ipt2,ipt4,ltelq) 444 : ipt3=ipt4 445 : endif 446 : go to 115 447 : endif 448 : enddo 449 : 115 continue 450 : * faut-il nommer le groupe? 451 : if(mlmot1.eq.0) then 452 : cha8=cha32 453 : do iaux=1,8 454 : IRAL=INDEX(MINU,cha8(IAUX:IAUX)) 455 : IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) 456 : enddo 456 : call nomobj('MAILLAGE',cha8,ipt3) 457 : * write(6,*) 'affectation du nom ' , cha8, ipt3 457 : * call ecmail (ipt3,0) 458 : else 459 : do jou=1,mlmot1.mots(/2) 460 : if(cha32.eq.mlmot1.mots(jou)) then 461 : cha8=mlmot2.mots(jou) 462 : do iaux=1,8 463 : IRAL=INDEX(MINU,cha8(IAUX:IAUX)) 464 : IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) 465 : enddo 465 : call nomobj('MAILLAGE',cha8,ipt3) 466 : * write (6,*) 'affectation groupe ' , cha8, ipt3 466 : * call ecmail(ipt3,0) 467 : go to 119 468 : endif 469 : enddo 470 : endif 471 : 119 continue 472 : enddo 473 : * 474 : * quelque suppressions 475 : * 476 : 477 : if(mlmot1.ne.0) then 478 : segdes mlmot1,mlmot2 479 : endif 480 : do iou=1,iffa 481 : numlis=inumli(iou) 482 : segsup numlis 483 : enddo 484 : do iou=1,infam 485 : nomg32=inogro(iou) 486 : segsup nomg32 487 : enddo 488 : * segsup maitot,lisnog,ijfam 489 : * 490 : * tentons de lire les champs 491 : * 492 : * write(6,*) ' appel a medrch ' 492 : call medrch(ifid,mlmot1,mlmot2,nbnoin,nommaa,nbpta,icret) 493 : 494 : * 495 : * fermeture du fichier 496 : * 496 : call efferm4(ifid,icret) 497 : return 498 : end 499 : 500 : 501 : 502 : 503 :
© Cast3M 2003 - All rights reserved.
Disclaimer