C MEDR SOURCE PASCAL 12/06/18 21:15:05 7403 subroutine medr implicit integer(i-n) implicit real*8(a-h,o-z) * opérateur med_restitution -INC CCOPTIO -INC SMELEME -INC SMCOORD -INC SMLMOTS -INC CCGEOME -INC SMTABLE -INC SMCHPOI * parameter (MED_LECTURE=0,MED_LECTURE_ECRITURE=1) * parameter (MED_LECTURE_AJOUT=2,MED_CREATION=3) * parameter (MED_FULL_INTERLACE=0, MED_NO_INTERLACE=1) * parameter (MED_NON_STRUCTURE=0,MED_STRUCTURE=1) * parameter (MED_GRILLE_CARTESIENNE=0,MED_GRILLE_POLAIRE=1) * parameter (MED_GRILLE_STANDARD=2) parameter (MED_MAILLE=0,MED_FACE=1,MED_ARETE=2,MED_NOEUD=3) * parameter (MED_POINT1=1,MED_SEG2=102,MED_SEG3=103,MED_TRIA3=203) * parameter (MED_TRIA6=206,MED_QUAD4=204,MED_QUAD8=208) * parameter (MED_TETRA4=304,MED_TETRA10=310,MED_HEXA8=308) * parameter (MED_HEXA20=320,MED_PENTA6=306) * parameter (MED_PENTA15=315,MED_PYRA5=305,MED_PYRA13=313) * parameter (MED_POLYGONE = 400, MED_POLYEDRE = 500, MED_NONE=0) * parameter (MED_NBR_GEOMETRIE_MAILLE = 15,MED_NBR_GEOMETRIE_FACE=4) * parameter (MED_NBR_GEOMETRIE_ARETE = 2) * parameter (MED_COOR=0,MED_CONN=1,MED_NOM=2,MED_NUM=3,MED_FAM=4) * parameter (MED_COOR_IND1=5,MED_COOR_IND2=6,MED_COOR_IND3=7) * parameter (MED_NOD=0, MED_DESC=1) * parameter (MED_CART=0,MED_CYL=1, MED_SPHER=2) * parameter (MED_INT32=24, MED_INT64=26,MED_FLOAT64=6) * parameter (MED_NOPG = 1) * character*32 MED_NOGAUSS * parameter (MED_NOGAUSS=' ') * character*32 MED_GAUSS_ELNO * parameter (MED_GAUSS_ELNO='MED_GAUSS_ELNO ') * parameter (MED_NOPF = 0) * character*32 MED_NOPFL * parameter (MED_NOPFL=' ') * parameter (MED_NONOR = -1) * parameter (MED_NONOR = -1) * parameter (MED_ALL = 0) parameter (MED_NO_PFLMOD=0, MED_GLOBAL=1, MED_COMPACT=2) * parameter (MED_MAILLAGE= 0) * parameter (MED_CHAMP= 1) character*72 cha72 character*8 cha8 character*32 NOMMAA,NOMFA,cha32,chb32,NOMMAP character*200 DESMAA character*48 COMP,UNIT character*8 nompoint logical bnoel,bnuel logical ltelq segment maitot integer ipomai(15),inumli(15) endsegment segment ijfam Integer infaa(infam),inogro(infam) character*32 nomfam(infam) endsegment segment iclame integer icla(320),itab(15) endsegment segment icoor real*8 xcoo(isdim,nbpta) endsegment * segment car128 character*16 icar(1000) * endsegment segment numele integer nume(INBELE) endsegment segment att integer attr(INBATT) integer attr2(INBATT) character*200 attr3(INBATT) endsegment segment lisnog character*32 lisno(jg) endsegment segment nomg32 character*80 nogr32(kg) endsegment external long segment numlis(INBELE) segment nomnoe(nbpta) segment numfampt(NBFAMPT) CHARACTER*26 MINU,MAJU character*72 medres DATA MINU/'abcdefghijklmnopqrstuvwxyz'/ DATA MAJU/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ segini iclame icla(1)=1 icla(102)=2 icla(103 )=3 icla(203 )=4 icla(206 )=6 icla(204 )=8 icla(208 )=10 icla(308 )=14 icla(320 )=15 icla(306 )=16 icla(315 )=17 icla(304 )=23 icla(310 )=24 icla(305 )=25 icla(313 )=26 itab(1)=1 itab(2)=102 itab(3)=103 itab(4)=203 itab(5)=206 itab(6)=204 itab(7)=208 itab(8)=308 itab(9)=320 itab(10)=306 itab(11)=315 itab(12)=304 itab(13)=310 itab(14)=305 itab(15)=313 nbnoin= xcoor(/1)/(idim+1) ndecco=xcoor(/1) * write(6,*) ' ndecco ' , ndecco ltelq=.TRUE. nbref=0 nbsous=0 call lircha(medres,1,iretou) if(ierr.ne.0) return call lircha(cha32,0,iretou) if(ierr.ne.0) return if (iretou.eq.0) cha32=' ' * SP : MLMOTS ???? call lirobj('MLMOTS',mlmot1,0,iretou) if(iretou.ne.0) then call lirobj('MLMOTS',mlmot2,1,iretou) if(ierr.ne.0) return segact mlmot1,mlmot2 if(mlmot1.mots(/2).ne.mlmot2.mots(/2)) then call erreur(19) return endif endif * * ici il faut lire * iloh=long(medres) call EFOUVR4(ifid,medres(1:iloh),0,ICRET) if(icret.ne.0) call efexit4(-1) nommap=' ' do i=1,100 nommaa=' ' call EFMAAI4(IFID,i,NOMMAA,ISDIM,ITYPEM,DESMAA,ICRET) if(NOMMAA.eq.cha32.and.cha32.ne.' ') goto 100 if(nommaa.ne.' ') then if (NOMMAA.eq.nommap) goto 99 write(ioimp,*) $ 'objet existant dans le fichier : ' , nommaa endif nommap=nommaa enddo 99 continue return 100 continue *0 = MED_COOR 3 = MED_NOEUD call EFNEMA4(IFID,NOMMAA,0,3,0,0,nbpta,ICRET) if(icret.ne.0) then * write (6,*) ' plouf efnema -1' call efexit4(-1) return endif * write(6,*) ' nbpta ' , nbpta nbpts=nbpta +nbnoin segadj mcoord segini icoor *0 = MED_FULL_INTERLACE 0=MED_ALL * write(6,*) ' appel à efcool' call EFCOOL4(IFID,NOMMAA,ISDIM,xcoo(1,1),0,0,0,0,IREPER,COMP & ,UNIT, ICRET,0,0) * write(6,*) ' sortie de efcool' if(icret.ne.0) then * write(6,*) ' plouf efcool 0' call efexit4(-1) return endif if(idim.lt.isdim) then iidim=idim idim=isdim segadj mcoord if(nbnoin.ne.0) then do iou=1,nbnoin nint1=(nbnoin+1-iou)*(idim+1) nint2=(nbnoin+1-iou)*(iidim+1) xcoor( nint1) =xcoor(nint2) do iau=1,iidim xcoor(nint1-idim-1+iau)=xcoor(nint2-iidim-1+iau) enddo enddo endif endif * write(6,*) ' nbpta isdim idim ' , nbpta,isdim,idim do iou=1,nbpta do jou=1,isdim xcoor(ndecco+jou+(iou-1)*(idim+1))=xcoo(jou,iou) enddo enddo * write(6,*) ' sortie de boucle iou jou ' segsup icoor * write(6,*) ' sortie de segsup icoor ' iffa=0 * write(6,*) ' avant segini maitot' segini maitot * write(6,*) ' apres segini maitot' * o, nomme le maillage complet nbref=0 nbsous=15 nbelem=0 nbnn=0 segini ipt1 DO ITYPEM=1,15 *MED_CONN=1 MED_NOD=0, MED_MAILLE=0 * write(6,*) ' appel a efnema itypem ',itypem call EFNEMA4(IFID,NOMMAA,1,0,ITAB(ITYPEM),0,inbele,ICRET) * write(6,*) ' sortie a efnema inbele' , inbele, nommaa if(icret.ne.0) then * write(6,*) ' plouf 1' call efexit4(-1) return endif if(INBELE.ne.0) then * write(6,*) ' itypem inbele ' ,itypem, inbele iffa=iffa+1 nbelem=inbele nbnn=nbnne(icla(itab(itypem))) * write(6,*) ' icla(itab(itypem)) ', icla(itab(itypem)) * write(6,*) 'nbnn ' , nbnn * write(6,*) 'itype ' , ITAB(ITYPEM) nbsous=0 nbref=0 segini meleme ipt1.lisous(iffa)=meleme * segini car128 segini numele segini numlis ipomai(iffa)=meleme inumli(iffa)=numlis * CALL EFELEL(IFID,NOMMAA,ISDIM,num,0,icar(1),BNOEL, * & , nume(1),BNUEL,numlis(1),INBELE,0,ITAB(ITYPEM),0, * & ICRET) nva0=num(/1)*num(/2) * CALL EFCONL(IFID,NOMMAA,ISDIM,num,0,0,0,0,ITAB(ITYPEM),0, * & ICREt) CALL EFCONL4(IFID,NOMMAA,ISDIM,num,0,0,0,0,ITAB(ITYPEM),0, & ICRET,num,nva0,0,0) * CALL EFFAML(IFID,NOMMAA,numlis(1),inbele,0,ITAB(ITYPEM), * & ICRET) CALL EFFAML4(IFID,NOMMAA,numlis(1),inbele,0,ITAB(ITYPEM), & ICRET,numlis(1)) * write(6,*) ' num',(( num(ik,j),ik=1,nbnn),j=1,inbele) do iyp=1,inbele icolor(iyp)=idcoul enddo * write(6,*) ' numlis',(numlis(j),j=1,inbele) * segsup car128,numele if(nbnoin.ne.0) then do iou=1,nbelem do jou=1,nbnn num(jou,iou)=num(jou,iou)+nbnoin enddo icolor(iou)=idcoul enddo endif itypel=icla(itab(itypem)) call medtra(meleme,2) ipomai(iffa)=meleme ipt1.lisous(iffa)=meleme endif ENDDO nbsous=iffa nbref=0 nbnn=0 nbref=0 segadj ipt1 segdes ipt1 cha8=nommaa do iaux=1,8 IRAL=INDEX(MINU,cha8(IAUX:IAUX)) IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) enddo call nomobj('MAILLAGE', cha8 , ipt1 ) * lecture des familles segini nomnoe * write(6,*) ' appel a effaml' CALL EFFAML4(IFID,NOMMAA,nomnoe(1),nbpta,3,0, & ICRET,nomnoe(1)) * write(6,*) ' sortie a effaml nbpta ', nbpta if(icret.ne.0) then * write(6,*) ' plouf 2' call efexit4(-1) return endif NBFAMPT = 0 * write(6,*) ' nomnoe ' , (nomnoe(iyt),iyt=1,nbpta) * DO IOU=1,nbpta * IF(nomnoe(IOU).ne.0) then * NBFAMPT = NBFAMPT+1 * endif * enddo * write(6,*)' nbfampt ', nbfampt * segini numfampt * write(6,*) ' appel a efnfam' CALL EFNFAM4(IFID,NOMMAA,INFAM,ICRET) * write(6,*) ' sortie a efnfam infam ', infam segini ijfam * write(6,*) ' infam ' , infam DO IFAM=1,INFAM CALL EFNGRO4(IFID,NOMMAA,IFAM,kg,ICRET) CALL EFNATT4(IFID,NOMMAA,IFAM,INBATT,ICRET) * write(6,*) ' inbatt ' , inbatt segini att segini nomg32 * write(6,*) ' appel effami inbatt kg ' ,inbatt,kg CALL EFFAMI4(IFID,NOMMAA,IFAM,NOMFA,INUMFA,attr,attr2, & attr3,INBATT,nogr32,kg,ICRET,attr,attr2) * if (INUMFA.lt.0) then * numfampt(-INUMFA)=IFAM * endif segsup att infaa(ifam)=INUMFA inogro(ifam)=nomg32 nomfam(ifam)=NOMFA * write(6,*) 'ifam infaa inogro nomfam',ifam, inumfa,nomg32,NOMFA * write(6,*) ' nogr32 ' , ( nogr32(iyu),iyu=1,nogr32(/2)) ENDDO * DO IOU=1,nbpta * IF (nomnoe(IOU).ne.0) then * ilocf=numfampt(-nomnoe(IOU)) * nompoint=nomfam(ilocf) * CALL NOMOBJ('POINT',nompoint,IOU+ndecco) * ENDIF * ENDDO * segsup numfampt segsup iclame * * creation de familles * nbref=0 nbsous=0 ipt3=0 do 104 iou=1,infam * write(6,*) ' boucle 104 iou iffa' , iou,iffa ipt3=0 inufam=infaa(iou) do 105 jou=1,iffa * write(6,*) ' boucle 105 jou' , jou numlis=inumli(jou) nbelem=0 do kou=1,numlis(/1) if(numlis(kou).eq.inufam) nbelem=nbelem+1 enddo if(nbelem.eq.0) go to 105 ipt1=ipomai(jou) nbnn=ipt1.num(/1) mmm= ipt1.num(/2) * write(6,*) ' dim ipt1 nbnn nbelem ' , nbnn,mmm segini ipt2 iel=0 ipt2.itypel=ipt1.itypel do kou=1,numlis(/1) if(numlis(kou).eq.inufam) then iel=iel+1 do mou=1,nbnn ipt2.num(mou,iel)=ipt1.num(mou,kou) enddo ipt2.icolor(iel)=idcoul endif enddo if(ipt3.eq.0) then ipt3=ipt2 else * write(6,*) ' appel fuse ipt3,ipt2',ipt3,ipt2 call fuse(ipt3,ipt2,ipt4,ltelq) ipt3=ipt4 endif 105 continue nbpo=0 do iyt=1,nomnoe(/1) if( nomnoe(iyt).eq.inufam) nbpo=nbpo+1 enddo if( nbpo.ne.0) then nbnn=1 nbelem=nbpo segini ipt2 iuy=0 ipt2.itypel=1 do iyt=1,nomnoe(/1) if(nomnoe(iyt).eq.inufam) then iuy=iuy+1 ipt2.num(1,iuy)=iyt+nbnoin ipt2.icolor(iuy)=idcoul endif enddo if( ipt3.eq.0) then ipt3=ipt2 else call fuse(ipt3,ipt2,ipt4,ltelq) ipt3=ipt4 endif endif infaa(iou)=ipt3 * write(6,*) 'infaa de = ', iou , ipt3 * faut-il nommer la famille? if(mlmot1.ne.0) then cha32=nomfam(iou) do mou=1,mlmot1.mots(/2) if(mlmot1.mots(mou).eq.cha32) then cha8=mlmot2.mots(mou) do iaux=1,8 IRAL=INDEX(MINU,cha8(IAUX:IAUX)) IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) enddo call nomobj('MAILLAGE',cha8,ipt3) * write(6,*) ' affectationdufamille ' , cha8,ipt3 * call ecmail( ipt3,0) go to 104 endif enddo endif 104 continue * * fabrication des groupes * * on fabrique d'abord la liste de noms de groupe lnomg=0 jg=10 segini lisnog do 110 iou=1,infam nomg32=inogro(iou) do 111 jou=1,nogr32(/2) cha32=nogr32(jou) do kou=1,lnomg if(lisno(kou).eq.cha32) go to 111 enddo lnomg=lnomg+1 if(lnomg.gt.jg) then jg=jg+20 segadj lisnog endif lisno(lnomg)=cha32 111 continue 110 continue * *allons-y groupe par groupe * do iou=1,lnomg cha32=lisno(iou) ipt3=0 * write(6,*) ' groupe numero ',iou, ' de nom : ' , cha32 do 115 jou=1,infam nomg32=inogro(jou) * write(6,*) ' nogr32(/2) ' , nogr32(/2) do kou=1,nogr32(/2) * write(6,*)cha32,nogr32(kou)(1:32) if(cha32.eq.nogr32(kou)(1:32))then * write(6,*) ' on a egalité' if(ipt3.eq.0)then ipt3=infaa(jou) else ipt2=infaa(jou) call fuse(ipt3,ipt2,ipt4,ltelq) ipt3=ipt4 endif go to 115 endif enddo 115 continue * faut-il nommer le groupe? if(mlmot1.eq.0) then cha8=cha32 do iaux=1,8 IRAL=INDEX(MINU,cha8(IAUX:IAUX)) IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) enddo call nomobj('MAILLAGE',cha8,ipt3) * write(6,*) 'affectation du nom ' , cha8, ipt3 * call ecmail (ipt3,0) else do jou=1,mlmot1.mots(/2) if(cha32.eq.mlmot1.mots(jou)) then cha8=mlmot2.mots(jou) do iaux=1,8 IRAL=INDEX(MINU,cha8(IAUX:IAUX)) IF (IRAL.NE.0) cha8(IAUX:IAUX)=MAJU(IRAL:IRAL) enddo call nomobj('MAILLAGE',cha8,ipt3) * write (6,*) 'affectation groupe ' , cha8, ipt3 * call ecmail(ipt3,0) go to 119 endif enddo endif 119 continue enddo * * quelque suppressions * if(mlmot1.ne.0) then segdes mlmot1,mlmot2 endif do iou=1,iffa numlis=inumli(iou) segsup numlis enddo do iou=1,infam nomg32=inogro(iou) segsup nomg32 enddo * segsup maitot,lisnog,ijfam * * tentons de lire les champs * * write(6,*) ' appel a medrch ' call medrch(ifid,mlmot1,mlmot2,nbnoin,nommaa,nbpta,icret) * * fermeture du fichier * call efferm4(ifid,icret) return end