C MEDS SOURCE PV 12/12/06 21:15:12 7594 ************************************************************************ * NOM : meds.eso * DESCRIPTION : Sortie d'un maillage au format .med ************************************************************************ * HISTORIQUE : 21/12/2010 : CHAT : création de la subroutine * HISTORIQUE : 7/06/2012 : JCARDO : l'argument MOT1 devient optionnel * + ajout de l'extension .med * HISTORIQUE : ************************************************************************ * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES * en cas de modification de ce sous-programme afin de faciliter * la maintenance ! ************************************************************************ * APPELÉ PAR : opérateur SORTir (prsort.eso) ************************************************************************ * ENTRÉES :: aucune * SORTIES :: aucune (sur fichier uniquement) ************************************************************************ * SYNTAXE (GIBIANE) : * * SORT 'MED' OBJi * * avec OBJi = [ MAILi | CHPOi | TABi ] * ************************************************************************ subroutine meds implicit integer(i-n) implicit real*8(a-h,o-z) * opérateur med_sauvegarde -inc CCOPTIO -INC SMELEME -INC SMCOORD -INC TMLCHA8 -INC CCGEOME -INC SMCHPOI -INC SMTABLE SEGMENT JSGTR(0) SEGMENT CSGT CHARACTER*8 CSGTR(0) ENDSEGMENT SEGMENT ISGT INTEGER ISGTR(0) ENDSEGMENT SEGMENT ILIST(ILL) dimension jcla(100) character*8 nomg,itypk,itypk2,notemp,ctyp logical ilogin,ZOPEN C DIMENSION medi(100) * DATA NOMS( 1),NOMS( 2),NOMS( 3),NOMS( 4),NOMS( 5),NOMS( 6), * . NOMS( 7),NOMS( 8),NOMS( 9),NOMS(10),NOMS(11),NOMS(12), * . NOMS(13),NOMS(14),NOMS(15),NOMS(16),NOMS(17),NOMS(18), * . NOMS(19),NOMS(20),NOMS(21),NOMS(22),NOMS(23),NOMS(24), * . NOMS(25),NOMS(26),NOMS(27),NOMS(28),NOMS(29),NOMS(30), ** . NOMS(31),NOMS(32),NOMS(33),NOMS(34),NOMS(35),NOMS(36), * . NOMS(37),NOMS(38),NOMS(39),NOMS(40),NOMS(41),NOMS(42), * . NOMS(43),NOMS(44),NOMS(45),NOMS(46),NOMS(47),NOMS(48) ** . / 'POI1','SEG2','SEG3','TRI3','TRI4','TRI6','TRI7','QUA4','QUA5', ** . 'QUA8','QUA9','RAC2','RAC3','CUB8','CU20','PRI6','PR15','LIA3', * . 'LIA4','LIA6','LIA8','MULT','TET4','TE10','PYR5','PY13','ATTA', * . 'SUPE','RAP3','LIP6','LIP8','POLY','CU27','PR21','TE15','PY19', * . 'SEG4','QU16','TR12','PR18','SEG6','TR21','QU36','C216','P126', * . 'TE56','PY91','SURE' / C classe Med des elements DATA jcla( 1),jcla( 2),jcla( 3),jcla( 4),jcla( 5),jcla( 6), . jcla( 7),jcla( 8),jcla( 9),jcla(10),jcla(11),jcla(12), . jcla(13),jcla(14),jcla(15),jcla(16),jcla(17),jcla(18), . jcla(19),jcla(20),jcla(21),jcla(22),jcla(23),jcla(24), . jcla(25),jcla(26),jcla(27),jcla(28),jcla(29),jcla(30), . jcla(31),jcla(32),jcla(33),jcla(34),jcla(35),jcla(36), . jcla(37),jcla(38),jcla(39),jcla(40),jcla(41),jcla(42), . jcla(43),jcla(44),jcla(45),jcla(46),jcla(47),jcla(48) . / 1,102,103, 203,204,206,207,204,205,208,209,204,206,308,320, . 306,315,306,308,312,316, 0,304,310,305,313, 0, 0, 8, 15, . 20, 0, 27, 21, 15, 19, 4, 16, 12, 18, 6, 21, 36,216,126, . 56, 91, 0 / DATA medi( 1),medi( 2),medi( 3),medi( 4),medi( 5),medi( 6), . medi( 7),medi( 8),medi( 9),medi(10),medi(11),medi(12), . medi(13),medi(14),medi(15),medi(16),medi(17),medi(18), . medi(19),medi(20),medi(21),medi(22),medi(23),medi(24), . medi(25),medi(26),medi(27),medi(28),medi(29),medi(30), . medi(31),medi(32),medi(33),medi(34),medi(35),medi(36), . medi(37),medi(38),medi(39),medi(40),medi(41),medi(42), . medi(43),medi(44),medi(45),medi(46),medi(47),medi(48) . / 0,1,1,2,2,2,2,2,2, . 2,2,1,1,3,3,3,3,2, . 2,2,2,0,3,3,3,3,0, . 0,0,2,2,2,3,3,3,3, . 1,2,2,3,1,2,2,3,3, . 3,3,0/ EXTERNAL LONG INTEGER MED_LECTURE,MED_LECTURE_ECRITURE INTEGER MED_LECTURE_AJOUT,MED_CREATION PARAMETER (MED_LECTURE=0,MED_LECTURE_ECRITURE=1) PARAMETER (MED_LECTURE_AJOUT=2,MED_CREATION=3) INTEGER MED_NON_STRUCTURE PARAMETER (MED_NON_STRUCTURE=0) INTEGER MED_FULL_INTERLACE PARAMETER (MED_FULL_INTERLACE=0) INTEGER MED_CART PARAMETER (MED_CART=0) INTEGER MED_NOD,MED_MAILLE,MED_NOEUD PARAMETER (MED_NOD=0,MED_MAILLE=0,MED_NOEUD=3) INTEGER MED_NOPDT,MED_NONOR,MED_NO_PFLMOD PARAMETER (MED_NOPDT = -1, MED_NONOR = -1, MED_NO_PFLMOD=0) INTEGER MED_INT32 PARAMETER (MED_INT32=24) CHARACTER*32 MED_NOGAUSS,MED_NOPFL PARAMETER(MED_NOGAUSS=' ') PARAMETER(MED_NOPFL=' ') C CHARACTER*8 NOBJ,MOTOPT,cha8a CHARACTER*32 FOBJ character*32 cha32a,cha32b character*16 cha16a,cha16b character*72 medsau segment ijfam * ifam pointeur sur un meleme, inogro pointeur sur un nomgro integer ifam(jg),inogro(jg),nfam endsegment segment nomgro * nogrou contient les noms des groupes qui inclus la famille character*8 nogrou(kg) integer noco endsegment segment nomg32 character*80 nogr32(kg) endsegment character*32 cha32 pointeur nomgr1.nomgro,nomgr2.nomgro segment numlis(nbele) segment icpr(xcoor(/1)/(idim+1)) segment kfam(nfam) segment ixyz real*8 xyz(idim,nno) endsegment segment nomnoe(nno) SEGMENT ITLAC(0) POINTEUR ITLAC1.ITLAC SEGMENT ISORTA CHARACTER*8 ISORTC(KS),nosort(ks) INTEGER ISORTI(KS) ENDSEGMENT segment lischp character*8 nochpo(nbchpo),nosupp(nbchpo) integer lichpo(nbchpo),lisgeo(nbchpo) endsegment segment famchp character*8 nofamc(nbfach) integer nufach(nbfach) endsegment segment fachun integer ifachp(nbpas),ifageo(nbpas),ifanup(nbpas) character*8 fanosu(nbpas) real*8 fadt(nbpas) endsegment segment nocomm character*16 nocom(nbcom+1),cunit(nbcom+1) integer iposco(nbcom) endsegment notemp='PRMA0000' nutemp=0 SEGINI ITLAC * IF (IIMPI.EQ.5) WRITE(IOIMP,799) * 799 FORMAT(' LECTURE DES OBJETS A MED-SAUVER') * WRITE(*,*) 'entree : sauv.med' meleme=0 KS=0 SEGINI ISORTA C Lecture du nom du fichier de sauvegarde (=> bypass de OPTI SORT) C (CONSERVE POUR COMPATIBILITE MAIS NON DOCUMENTE) CALL LIRCHA(MEDSAU,0,IRETOU) IF (IRETOU.EQ.0) THEN INQUIRE(UNIT=IOPER,OPENED=ZOPEN) IF (.NOT.ZOPEN) THEN CALL ERREUR(-212) WRITE(IOIMP,*) '(via OPTI "SORT")' MOTERR(1:8)='MED ' CALL ERREUR(705) RETURN ENDIF INQUIRE(UNIT=IOPER,NAME=NOMFIC) CLOSE(UNIT=IOPER,STATUS='DELETE') * * Ajout de l'extension au nom du fichier CALL LENCHA(NOMFIC,LC) MEDSAU=NOMFIC(1:LC) IF (MEDSAU(LC-3:LC).NE.'.med') MEDSAU(LC+1:LC+4)='.med' ENDIF 1 CONTINUE INTEXT=1 CTYP=' ' CALL QUETYP(CTYP,0,IRETOU) IF(IRETOU.NE.1) GO TO 100 CALL LIROBJ(CTYP,IRET,0,IRETOU) C-------ON CONTROLE LA VALIDITE DU TYPE DEMANDE K=0 CALL TYPFIL (CTYP,K) IF (K.LT.0) THEN C---------- ON NE SAIT PAS SORTIR UN OBJET DE CE TYPE MOTERR(1:8)=CTYP CALL ERREUR(242) RETURN ENDIF C------- LE TYPE EST OK KS=ISORTI(/1)+1 SEGADJ ISORTA * write(6,*) ' ctyp ' , ctyp if(ctyp.eq.'MAILLAGE' . and .meleme.eq.0) then call quenom(NOBJ) meleme=iret segact meleme CALL AJOU(ITLAC,MELEME) IF(LISOUS(/1).NE.0) THEN DO 2 I=1,LISOUS(/1) IVAL=LISOUS(I) CALL AJOU(ITLAC,IVAL) 2 CONTINUE ENDIF else call quenom(cha8a) endif nosort(ks)=cha8a ISORTC(KS)=CTYP ISORTI(KS)=IRET GO TO 1 C---- ON A EXPLORE TOUTES LES DEMANDES 100 CONTINUE LOBJ=ISORTI(/1) IF(LOBJ.lt.1.or.meleme.eq.0) then call erreur(1013) return endif * * traitement des demandes pour remplir completement * la liste des maillages avant de faire le tasspo * nbnn=1 nbref=0 nbsous=0 nbchpo=0 nbch=0 segini lischp nbfach=0 nbfa=0 segini famchp do ia=1,lobj if(isortc(ia).eq.'CHPOINT') then nbch=nbch+1 if(nbch.gt.nbchpo) then nbchpo=nbchpo+20 segadj lischp endif mchpoi=isorti(ia) lichpo(nbch)=isorti(ia) nochpo(nbch)=nosort(ia) * on nomme tout de suite les objets maillage de profiles mchpoi=isorti(ia) segact mchpoi nbelem=0 do ic=1,ipchp(/1) msoupo=ipchp(ic) segact msoupo ipt1=igeoc segact ipt1 nbelem=IPT1.num(/2)+nbelem enddo segini ipt2 ipt2.itypel=1 ipp=0 do ic=1,ipchp(/1) msoupo=ipchp(ic) ipt1=igeoc do iu=1,ipt1.num(/2) ipt2.num(1,iu+ipp)=ipt1.num(1,iu) enddo ipp=ipp+ipt1.num(/2) segdes msoupo,ipt1 enddo nutemp=nutemp+1 if(nutemp.lt.10) then write(notemp(8:8),fmt='(i1)')nutemp elseif(nutemp.le.100) then write(notemp(7:8),fmt='(i2)')nutemp elseif(nutemp.le.1000) then write(notemp(6:8),fmt='(i3)')nutemp elseif(nutemp.le.10000) then write(notemp(5:8),fmt='(i4)')nutemp else * write(6,*) ' coucou 10' call erreur (1014) return endif segdes ipt2 call nomobj('MAILLAGE',notemp,ipt2) nosupp(nbch)=notemp lisgeo(nbch)=ipt2 elseif(isortc(ia).eq.'TABLE') then * recherche des indices temps deplacement temperarures contraintes mtable=isorti(ia) itypk=' ' call acctab(mtable,'MOT ',ivalin,xvalin,'TEMPS', $ ilogin,iobjin,itypk,ivalin,xvalin,cha8a,ilogin,mtabte) * write(6,*) ' 1 itypk ' ,itypk if(itypk.eq.' ') then * write(6,*) ' coucou 11' call erreur (1014) return elseif(itypk.eq.'TABLE' )then itypk=' ' icachp=1 call acctab(mtable,'MOT ',ivalin,xvalin,'DEPLACEMENTS', $ ilogin,iobjin,itypk,ivalin,xvalin,cha8a,ilogin,mtabde) * write(6,*) ' 2 itypk ' ,itypk if(itypk.eq.' ') then icachp=2 call acctab(mtable,'MOT ',ivalin,xvalin, $ 'TEMPERATURES',ilogin,iobjin,itypk,ivalin,xvalin,cha8a, $ ilogin,mtabde) * write(6,*) ' 3 itypk ' ,itypk endif if( itypk.ne.'TABLE' ) then * write(6,*) ' coucou 12' call erreur (1014) return endif mtab1=mtabde mtab2=mtabte segact mtab1,mtab2 do ib=1,mtab1.mlotab-1 itypk=' ' call acctab(mtab2,'ENTIER ',ib,xva,cha8a,ilogin,iobjin, $ itypk,iu,dt,cha8a,ilogin,iobjre) itypk2=' ' call acctab(mtab1,'ENTIER ',ib,xva,cha8a,ilogin,iobjin, $ itypk2,iu,xva,cha8a,ilogin,iobchp) if(itypk.ne.'FLOTTANT'. or.itypk2.ne.'CHPOINT') then * write(6,*) ' coucou 13 ib ',ib call erreur (1014) return endif if(ib.eq.1) then nbfach=nbfach+1 segadj famchp if(icachp.eq.1)nofamc(nbfach)='DEPLACEMENTS' if(icachp.eq.2)nofamc(nbfach)='TEMPERATURES' segact mtab2 nbpas=mtab2.mlotab-1 segini fachun nufach(nbfach)=fachun endif ifachp(ib)=iobchp fadt(ib)=dt ifanup(ib)=ib * on nomme tout de suite les objets maillage de profiles mchpoi=iobchp segact mchpoi nbref=0 nbsous=0 nbnn=1 nbelem=0 do ic=1,ipchp(/1) msoupo=ipchp(ic) segact msoupo ipt1=igeoc segact ipt1 nbelem=IPT1.num(/2)+nbelem enddo segini ipt2 ipt2.itypel=1 ipp=0 do ic=1,ipchp(/1) msoupo=ipchp(ic) ipt1=igeoc do iu=1,ipt1.num(/2) ipt2.num(1,iu+ipp)=ipt1.num(1,iu) enddo ipp=ipp+ipt1.num(/2) segdes msoupo,ipt1 enddo nutemp=nutemp+1 if(nutemp.lt.10) then write(notemp(8:8),fmt='(i1)')nutemp elseif(nutemp.le.100) then write(notemp(7:8),fmt='(i2)')nutemp elseif(nutemp.le.1000) then write(notemp(6:8),fmt='(i3)')nutemp elseif(nutemp.le.10000) then write(notemp(5:8),fmt='(i4)')nutemp else * write(6,*) ' coucou 14' call erreur (1014) return endif segdes ipt2 call nomobj('MAILLAGE',notemp,ipt2) fanosu(ib)=notemp ifageo(ib)=ipt2 enddo else * write(6,*) ' coucou 15' call erreur(1014) return endif elseif(isortc(ia).eq.'MAILLAGE') then else * write(6,*) ' coucou 16' call erreur (1014) return endif enddo * * on attaque la renumerotation * * write(6,*) ' appel a tasspo' ,(itlac(iou),iou=1,itlac(/1)) CALL TASSPO(ITLAC,icolac,ipt8,0) * write(6,*) ' sortie de tasspo' segini,ITLAC1=ITLAC CALL SUPPIL(ICOLAC,-1) ITLAC=ITLAC1 segsup ipt8 IF (IERR.NE.0) RETURN SEGACT MELEME IMAX=0 * * on ecrit d'abord les maillages * imel=meleme * write(6,*) ' itlac(/1)',itlac(/1) do 6 iuy=1,itlac(/1) meleme=itlac(iuy) segact meleme DO 5 IK=1,MAX(1,LISOUS(/1)) IF (LISOUS(/1).NE.0)THEN IPT1=LISOUS(IK) SEGACT IPT1 ELSE IPT1=MELEME ENDIF DO 3 J=1,IPT1.NUM(/2) DO 31 I=1,IPT1.NUM(/1) IMAX=MAX(IMAX,IPT1.NUM(I,J)) 31 CONTINUE 3 CONTINUE IF (LISOUS(/1).NE.0) SEGDES IPT1 5 CONTINUE 6 continue meleme=imel nno=imax * write(6,*) ' ecriture de ' , nno ,' noeuds' segini ixyz do i=1,nno do j=1,idim xyz(j,i)=xcoor( (i-1)*(idim+1) +j) enddo enddo * WRITE(*,*) 'Coucou : sauv.med' ILON=LONG(MEDSAU) CALL EFOUVR4(IFID,MEDSAU(1:ilon),MED_CREATION,ICRET) IF(ICRET.NE.0) THEN * WRITE(*,*) 'Erreur ouverture du fichier : sauv.med' ENDIF CALL EFMAAC4(IFID,NOBJ,IDIM,MED_NON_STRUCTURE,NOBJ,ICRET) call efespc4(ifid,nobj,idim,icret) CALL EFCOOE4(IFID,NOBJ,IDIM,xyz,MED_FULL_INTERLACE, & nno,MED_CART,MED_NOGAUSS,MED_NOGAUSS,ICRET) * * création des familles * segini icpr jg=100 segini ijfam segini jsgtr call quidan(jsgtr,itlac,imax) C dans jsgtr liste des objets maillages ilong=jsgtr(/1) call repert('MAILLAGE',ititi) call replis('MAILLAGE',MLCHA8) segact mlcha8 do 10 iou=1,ititi call lirobj('MAILLAGE',IOB,1,iretou) if(ierr.ne.0) return if(iob.eq.0) go to 10 do 11 jou=1,ilong if(iob.eq.jsgtr(jou)) go to 12 11 continue go to 10 12 continue nomg=mlchar(iou) call disj(iob,icpr,ijfam,nomg) 10 continue * * famille des points * SEGINI nomnoe call repert('POINT ',ititi) if( ititi.ne.0) then kg=1 segini nomg32 * write(6,*) ' ititi ' , ititi call replis('POINT ',MLCHA8) segact mlcha8 ineg=0 do 110 iou=1,ititi call lirobj('POINT',IOB,1,iretou) if(ierr.ne.0) return if(iob.eq.0) go to 110 * write(6,*) ' iob nnp', iob , nno if(iob.gt.nno) go to 110 if(nomnoe(iob).ne.0) go to 110 nogr32(1)=mlchar(iou) INEG=INEG-1 nomnoe(iob)=INEG fobj(1:3)='FAP' iu=-ineg if( iu .lt.10)then ilong=4 write(fobj(4:4),156) iu elseif(iu.lt.100) then ilong=5 write(fobj(4:5),157) iu elseif(iu.lt.1000) then ilong=6 write(fobj(4:6),158) iu elseif(iu.lt.10000) then ilong=7 write(fobj(4:7),159) iu elseif(iu.lt.100000) then ilong=8 write(fobj(4:8),160) iu else call erreur(19) return endif * write(6,*) ' nom du point ',nomg,' numero' , iob,ineg CALL EFFAMC4(IFID,NOBJ,FOBJ(1:ilong),INEG,0,0,0,0,nogr32(1), $ 1,ICRET,0,0) 110 continue CALL EFFAME4(IFID,NOBJ,nomnoe(1),nno,MED_NOEUD,0,ICRET,nomnoe(1)) endif SEGSUP nomnoe * * fabrication de la famille 0 et des numeros locaux d'elements dans la famille 0 * iu=1 nbsous=0 nbref=0 segini kfam do 50 iou=1,nfam ipt1=ifam(iou) segact ipt1 itype=ipt1.itypel if( kfam(iou).eq.0) then ipt2=ipt1 nbele=ipt2.num(/2) segini numlis do kou=1,nbele numlis(kou)=iu enddo nomgro=inogro(iou) segact nomgro kg=nogrou(/2) segini nomg32 do mou=1,kg nogr32(mou)=nogrou(mou) enddo fobj(1:3)='FAM ' * write(6,*) ' famille ' ,i if( iu .lt.10)then ilong=4 write(fobj(4:4),156) iu elseif(iu.lt.100) then ilong=5 write(fobj(4:5),157) iu elseif(iu.lt.1000) then ilong=6 write(fobj(4:6),158) iu elseif(iu.lt.10000) then ilong=7 write(fobj(4:7),159) iu elseif(iu.lt.100000) then ilong=8 write(fobj(4:8),160) iu else call erreur(19) return endif * WRITE(*,*) 'Ecriture ',FOBJ(1:ILONG),IU CALL EFFAMC4(IFID,NOBJ,FOBJ(1:ilong),iu,0,0,0,0,nogr32(1), & noco,ICRET,0,0) iu=iu+1 ifam(iou)=1 nbelei= nbele kfam(iou)=1 else go to 50 endif do jou=iou+1,nfam ipt3=ifam(jou) segact ipt3 if(ipt3.itypel.eq.itype) then kfam(jou)=1 nbnn=ipt2.num(/1) nbelem= ipt2.num(/2)+ipt3.num(/2) segadj ipt2 do lou=1,ipt3.num(/2) do mou=1,nbnn ipt2.num(mou,lou+nbelei)= ipt3.num( mou,lou) enddo enddo nbele=ipt3.num(/2)+nbelei segadj numlis do lou=1,ipt3.num(/2) numlis(lou+nbelei)=iu enddo nbelei=nbele nomgro=inogro(jou) segact nomgro kg=nogrou(/2) segini nomg32 do mou=1,kg nogr32(mou)=nogrou(mou) enddo fobj(1:3)='FAM' * write(6,*) ' famille ' ,i if( iu .lt.10)then ilong=4 write(fobj(4:4),156) iu 156 format(i1) elseif(iu.lt.100) then ilong=5 write(fobj(4:5),157) iu 157 format(i2) elseif(iu.lt.1000) then ilong=6 write(fobj(4:6),158) iu 158 format(i3) elseif(iu.lt.10000) then ilong=7 write(fobj(4:7),159) iu 159 format(i4) elseif(iu.lt.100000) then ilong=8 write(fobj(4:8),160) iu 160 format(i5) else call erreur(19) return endif * WRITE(*,*) 'Ecriture ',FOBJ(1:ILONG),IU CALL EFFAMC4(IFID,NOBJ,FOBJ(1:ilong),iu,0,0,0,0,nogr32(1), & noco,ICRET,0,0) iu=iu+1 endif enddo ITCELL=jcla(ipt2.itypel) iptanc=ipt2 nvao=ipt2.num(/2)*ipt2.num(/1) call medtra(ipt2,1) CALL EFCONE4(IFID,NOBJ,medi(ipt2.itypel),ipt2.num, & MED_FULL_INTERLACE,ipt2.num(/2),MED_MAILLE,ITCELL, & MED_NOD,ICRET,ipt2.num,nvao) * write(6,*) ' sortie de efcone4 1' CALL EFFAME4(IFID,NOBJ,numlis(1),numlis(/1),MED_MAILLE, & ITCELL,ICRET,numlis(1)) * write(6,*) ' sortie de effame4 1' if(ipt2.ne.iptanc) segsup ipt2 50 continue CALL EFFAMC4(IFID,NOBJ,'FAM00',0,0,0,0,0,' ',0,ICRET,0,0) * write(6,*) ' sortie de effamc4 1' * * au tour des champpoint on commence par les chpoint isolés * do ia=1,nbch ipt1=lisgeo(ia) segact ipt1 n=ipt1.num(/2) cha32a=nosupp(ia) * write(6,*) ' on veut creer le profil ', cha32a call efpfle4(ifid,ipt1.num,n,cha32a,icret,ipt1.num) if(icret.ne.0) then moterr(1:4)='MEDS' interr(1)=1 call erreur(873) return endif segsup ipt1 call nomobj('ANNULE ',cha32a,iiii) nbcom=100 segini nocomm mchpoi=lichpo(ia) segact mchpoi nccc=0 idej=0 do ib=1,ipchp(/1) msoupo= ipchp(ib) segact msoupo if(ib.eq.1) then do ic=1,nocomp(/2) nocom(ic)(1:4)=nocomp(ic) enddo nccc=nocomp(/2) else do ic=1,nocomp(/2) do id=1,nccc if( nocomp(ic).eq.nocom(id)(1:4)) go to 745 enddo nccc=nccc+1 nocom(nccc)(1:4)=nocomp(ic) 745 continue enddo endif enddo nc=nccc segini mpova2 do ib=1,ipchp(/1) msoupo=ipchp(ib) do ic=1,nocomp(/2) do id=1,nccc if( nocomp(ic).eq.nocom(id)(1:4)) then iposco(ic)=id go to 746 endif enddo 746 continue enddo mpoval=ipoval segact mpoval do ie=1,nocomp(/2) id=iposco(ie) do ic=1,vpocha(/1) mpova2.vpocha(ic+idej,id)=vpocha(ic,ie) enddo enddo idej=idej+vpocha(/1) segdes msoupo,mpoval enddo cha32a=nochpo(ia) cha32b=nosupp(ia) * write(6,*) ' declaration dedu champ ', cha32a(1:8) * write(6,*) ' de composantes : ' ,(nocom(iou),iou=1,nccc) call efchac4(ifid,cha32a,6,nocom,cunit,nccc,icret) * write(6,*)' les 2 premieres valeurs associees sont :' * write(6,*) mpova2.vpocha(1,1),mpova2.vpocha(2,1) nccn=n*nccc call efchae4(ifid,nobj,cha32a,mpova2.vpocha,0,nccn,MED_NOGAUSS, 1 0,cha32b,2,3,0,1,' ', 1 0.d0,0,icret) segsup mpova2,nocomm segdes mchpoi enddo segsup lischp * * au tour des familles de champs * do ia=1, nbfach cha32a = nofamc(ia) fachun=nufach(ia) do ib=1,ifachp(/1) ipt1=ifageo(ib) segact ipt1 n=ipt1.num(/2) cha32b=fanosu(ib) * write(6,*) ' on veut creer le profil ', cha32b call efpfle4(ifid,ipt1.num,n,cha32b,icret,ipt1.num) if(icret.ne.0) then moterr(1:4)='MEDS' interr(1)=1 call erreur(873) return endif segsup ipt1 call nomobj('ANNULE ',cha32b,iiii) nbcom=100 segini nocomm mchpoi=ifachp(ib) segact mchpoi nccc=0 idej=0 do ie=1,ipchp(/1) msoupo= ipchp(ie) segact msoupo if(ie.eq.1) then do ic=1,nocomp(/2) nocom(ic)(1:16)=nocomp(ic) enddo nccc=nocomp(/2) * write(6,*)'ie nccc nocom ',ie,nccc,(nocom(iuy),iuy=1,nccc) else do ic=1,nocomp(/2) do id=1,nccc if( nocomp(ic).eq.nocom(id)(1:4)) go to 755 enddo nccc=nccc+1 nocom(nccc)(1:16)=nocomp(ic) * write(6,*)'ie nccc nocom ',ie,nccc,(nocom(iuy),iuy=1,nccc) 755 continue enddo endif enddo nc=nccc segini mpova2 do ie=1,ipchp(/1) msoupo=ipchp(ie) do ic=1,nocomp(/2) do id=1,nccc if( nocomp(ic).eq.nocom(id)(1:4)) then iposco(ic)=id go to 756 endif enddo 756 continue enddo mpoval=ipoval segact mpoval do ig=1,nocomp(/2) id=iposco(ig) do ic=1,vpocha(/1) mpova2.vpocha(ic+idej,id)=vpocha(ic,ig) enddo enddo idej=idej+vpocha(/1) segdes msoupo,mpoval enddo xpas=fadt(ib) nump=ifanup(ib) * write(6,*) ' declaration dedu champ ', cha32a(1:8) * write(6,*) ' de composantes : ' ,(nocom(iou),iou=1,nccc) call efchac4(ifid,cha32a,6,nocom,cunit,nccc,icret) call efchae4(ifid,nobj,cha32a,mpova2.vpocha,0,n*nccc, 1 MED_NOGAUSS,0,cha32b,2,3,0,nump,' ', 1 xpas,0,icret) segsup mpova2,nocomm segdes mchpoi enddo segsup fachun enddo segsup famchp CALL EFFERM4(IFID,ICRET) * write(6,*) ' sortie de meds!!!' IF(ICRET.NE.0) THEN moterr(1:4)='MEDS' interr(1)=1 call erreur(873) ENDIF return end