1 : C MEDS SOURCE PV 12/12/06 21:15:12 7594 2 : ************************************************************************ 3 : * NOM : meds.eso 4 : * DESCRIPTION : Sortie d'un maillage au format .med 5 : ************************************************************************ 6 : * HISTORIQUE : 21/12/2010 : CHAT : création de la subroutine 7 : * HISTORIQUE : 7/06/2012 : JCARDO : l'argument MOT1 devient optionnel 8 : * + ajout de l'extension .med 9 : * HISTORIQUE : 10 : ************************************************************************ 11 : * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES 12 : * en cas de modification de ce sous-programme afin de faciliter 13 : * la maintenance ! 14 : ************************************************************************ 15 : * APPELÉ PAR : opérateur SORTir (prsort.eso) 16 : ************************************************************************ 17 : * ENTRÉES :: aucune 18 : * SORTIES :: aucune (sur fichier uniquement) 19 : ************************************************************************ 20 : * SYNTAXE (GIBIANE) : 21 : * 22 : * SORT 'MED' OBJi 23 : * 24 : * avec OBJi = [ MAILi | CHPOi | TABi ] 25 : * 26 : ************************************************************************ 27 : subroutine meds 28 : implicit integer(i-n) 29 : implicit real*8(a-h,o-z) 30 : * opérateur med_sauvegarde 31 : -inc CCOPTIO 32 : -INC SMELEME 33 : -INC SMCOORD 34 : -INC TMLCHA8 35 : -INC CCGEOME 36 : -INC SMCHPOI 37 : -INC SMTABLE 38 : SEGMENT JSGTR(0) 39 : SEGMENT CSGT 40 : CHARACTER*8 CSGTR(0) 41 : ENDSEGMENT 42 : SEGMENT ISGT 43 : INTEGER ISGTR(0) 44 : ENDSEGMENT 45 : SEGMENT ILIST(ILL) 46 : dimension jcla(100) 47 : character*8 nomg,itypk,itypk2,notemp,ctyp 48 : logical ilogin,ZOPEN 49 : C 50 : 51 : DIMENSION medi(100) 52 : * DATA NOMS( 1),NOMS( 2),NOMS( 3),NOMS( 4),NOMS( 5),NOMS( 6), 53 : * . NOMS( 7),NOMS( 8),NOMS( 9),NOMS(10),NOMS(11),NOMS(12), 54 : * . NOMS(13),NOMS(14),NOMS(15),NOMS(16),NOMS(17),NOMS(18), 55 : * . NOMS(19),NOMS(20),NOMS(21),NOMS(22),NOMS(23),NOMS(24), 56 : * . NOMS(25),NOMS(26),NOMS(27),NOMS(28),NOMS(29),NOMS(30), 57 : ** . NOMS(31),NOMS(32),NOMS(33),NOMS(34),NOMS(35),NOMS(36), 58 : * . NOMS(37),NOMS(38),NOMS(39),NOMS(40),NOMS(41),NOMS(42), 59 : * . NOMS(43),NOMS(44),NOMS(45),NOMS(46),NOMS(47),NOMS(48) 60 : ** . / 'POI1','SEG2','SEG3','TRI3','TRI4','TRI6','TRI7','QUA4','QUA5', 61 : ** . 'QUA8','QUA9','RAC2','RAC3','CUB8','CU20','PRI6','PR15','LIA3', 62 : * . 'LIA4','LIA6','LIA8','MULT','TET4','TE10','PYR5','PY13','ATTA', 63 : * . 'SUPE','RAP3','LIP6','LIP8','POLY','CU27','PR21','TE15','PY19', 64 : * . 'SEG4','QU16','TR12','PR18','SEG6','TR21','QU36','C216','P126', 65 : * . 'TE56','PY91','SURE' / 66 : C classe Med des elements 67 : DATA jcla( 1),jcla( 2),jcla( 3),jcla( 4),jcla( 5),jcla( 6), 68 : . jcla( 7),jcla( 8),jcla( 9),jcla(10),jcla(11),jcla(12), 69 : . jcla(13),jcla(14),jcla(15),jcla(16),jcla(17),jcla(18), 70 : . jcla(19),jcla(20),jcla(21),jcla(22),jcla(23),jcla(24), 71 : . jcla(25),jcla(26),jcla(27),jcla(28),jcla(29),jcla(30), 72 : . jcla(31),jcla(32),jcla(33),jcla(34),jcla(35),jcla(36), 73 : . jcla(37),jcla(38),jcla(39),jcla(40),jcla(41),jcla(42), 74 : . jcla(43),jcla(44),jcla(45),jcla(46),jcla(47),jcla(48) 75 : . / 1,102,103, 203,204,206,207,204,205,208,209,204,206,308,320, 76 : . 306,315,306,308,312,316, 0,304,310,305,313, 0, 0, 8, 15, 77 : . 20, 0, 27, 21, 15, 19, 4, 16, 12, 18, 6, 21, 36,216,126, 78 : . 56, 91, 0 / 79 : DATA medi( 1),medi( 2),medi( 3),medi( 4),medi( 5),medi( 6), 80 : . medi( 7),medi( 8),medi( 9),medi(10),medi(11),medi(12), 81 : . medi(13),medi(14),medi(15),medi(16),medi(17),medi(18), 82 : . medi(19),medi(20),medi(21),medi(22),medi(23),medi(24), 83 : . medi(25),medi(26),medi(27),medi(28),medi(29),medi(30), 84 : . medi(31),medi(32),medi(33),medi(34),medi(35),medi(36), 85 : . medi(37),medi(38),medi(39),medi(40),medi(41),medi(42), 86 : . medi(43),medi(44),medi(45),medi(46),medi(47),medi(48) 87 : . / 0,1,1,2,2,2,2,2,2, 88 : . 2,2,1,1,3,3,3,3,2, 89 : . 2,2,2,0,3,3,3,3,0, 90 : . 0,0,2,2,2,3,3,3,3, 91 : . 1,2,2,3,1,2,2,3,3, 92 : . 3,3,0/ 93 : EXTERNAL LONG 94 : INTEGER MED_LECTURE,MED_LECTURE_ECRITURE 95 : INTEGER MED_LECTURE_AJOUT,MED_CREATION 96 : PARAMETER (MED_LECTURE=0,MED_LECTURE_ECRITURE=1) 97 : PARAMETER (MED_LECTURE_AJOUT=2,MED_CREATION=3) 98 : INTEGER MED_NON_STRUCTURE 99 : PARAMETER (MED_NON_STRUCTURE=0) 100 : INTEGER MED_FULL_INTERLACE 101 : PARAMETER (MED_FULL_INTERLACE=0) 102 : INTEGER MED_CART 103 : PARAMETER (MED_CART=0) 104 : INTEGER MED_NOD,MED_MAILLE,MED_NOEUD 105 : PARAMETER (MED_NOD=0,MED_MAILLE=0,MED_NOEUD=3) 106 : INTEGER MED_NOPDT,MED_NONOR,MED_NO_PFLMOD 107 : PARAMETER (MED_NOPDT = -1, MED_NONOR = -1, MED_NO_PFLMOD=0) 108 : INTEGER MED_INT32 109 : PARAMETER (MED_INT32=24) 110 : CHARACTER*32 MED_NOGAUSS,MED_NOPFL 111 : PARAMETER(MED_NOGAUSS=' ') 112 : PARAMETER(MED_NOPFL=' ') 113 : 114 : C 115 : CHARACTER*8 NOBJ,MOTOPT,cha8a 116 : CHARACTER*32 FOBJ 117 : character*32 cha32a,cha32b 118 : character*16 cha16a,cha16b 119 : character*72 medsau 120 : segment ijfam 121 : * ifam pointeur sur un meleme, inogro pointeur sur un nomgro 122 : integer ifam(jg),inogro(jg),nfam 123 : endsegment 124 : segment nomgro 125 : * nogrou contient les noms des groupes qui inclus la famille 126 : character*8 nogrou(kg) 127 : integer noco 128 : endsegment 129 : segment nomg32 130 : character*80 nogr32(kg) 131 : endsegment 132 : character*32 cha32 133 : pointeur nomgr1.nomgro,nomgr2.nomgro 134 : segment numlis(nbele) 135 : segment icpr(xcoor(/1)/(idim+1)) 136 : segment kfam(nfam) 137 : segment ixyz 138 : real*8 xyz(idim,nno) 139 : endsegment 140 : segment nomnoe(nno) 141 : SEGMENT ITLAC(0) 142 : POINTEUR ITLAC1.ITLAC 143 : SEGMENT ISORTA 144 : CHARACTER*8 ISORTC(KS),nosort(ks) 145 : INTEGER ISORTI(KS) 146 : ENDSEGMENT 147 : segment lischp 148 : character*8 nochpo(nbchpo),nosupp(nbchpo) 149 : integer lichpo(nbchpo),lisgeo(nbchpo) 150 : endsegment 151 : segment famchp 152 : character*8 nofamc(nbfach) 153 : integer nufach(nbfach) 154 : endsegment 155 : segment fachun 156 : integer ifachp(nbpas),ifageo(nbpas),ifanup(nbpas) 157 : character*8 fanosu(nbpas) 158 : real*8 fadt(nbpas) 159 : endsegment 160 : segment nocomm 161 : character*16 nocom(nbcom+1),cunit(nbcom+1) 162 : integer iposco(nbcom) 163 : endsegment 164 : notemp='PRMA0000' 165 : nutemp=0 166 : SEGINI ITLAC 167 : * IF (IIMPI.EQ.5) WRITE(IOIMP,799) 168 : * 799 FORMAT(' LECTURE DES OBJETS A MED-SAUVER') 169 : * WRITE(*,*) 'entree : sauv.med' 170 : meleme=0 171 : KS=0 172 : SEGINI ISORTA 173 : 174 : C Lecture du nom du fichier de sauvegarde (=> bypass de OPTI SORT) 175 : C (CONSERVE POUR COMPATIBILITE MAIS NON DOCUMENTE) 175 : CALL LIRCHA(MEDSAU,0,IRETOU) 176 : IF (IRETOU.EQ.0) THEN 177 : INQUIRE(UNIT=IOPER,OPENED=ZOPEN) 178 : IF (.NOT.ZOPEN) THEN 178 : CALL ERREUR(-212) 179 : WRITE(IOIMP,*) '(via OPTI "SORT")' 180 : MOTERR(1:8)='MED ' 180 : CALL ERREUR(705) 181 : RETURN 182 : ENDIF 183 : INQUIRE(UNIT=IOPER,NAME=NOMFIC) 184 : CLOSE(UNIT=IOPER,STATUS='DELETE') 185 : * 186 : * Ajout de l'extension au nom du fichier 186 : CALL LENCHA(NOMFIC,LC) 187 : MEDSAU=NOMFIC(1:LC) 188 : IF (MEDSAU(LC-3:LC).NE.'.med') MEDSAU(LC+1:LC+4)='.med' 189 : ENDIF 190 : 191 : 1 CONTINUE 192 : INTEXT=1 193 : CTYP=' ' 193 : CALL QUETYP(CTYP,0,IRETOU) 194 : IF(IRETOU.NE.1) GO TO 100 194 : CALL LIROBJ(CTYP,IRET,0,IRETOU) 195 : C-------ON CONTROLE LA VALIDITE DU TYPE DEMANDE 196 : K=0 196 : CALL TYPFIL (CTYP,K) 197 : IF (K.LT.0) THEN 198 : C---------- ON NE SAIT PAS SORTIR UN OBJET DE CE TYPE 199 : MOTERR(1:8)=CTYP 199 : CALL ERREUR(242) 200 : RETURN 201 : ENDIF 202 : C------- LE TYPE EST OK 203 : KS=ISORTI(/1)+1 204 : SEGADJ ISORTA 205 : * write(6,*) ' ctyp ' , ctyp 206 : if(ctyp.eq.'MAILLAGE' . and .meleme.eq.0) then 206 : call quenom(NOBJ) 207 : meleme=iret 208 : segact meleme 208 : CALL AJOU(ITLAC,MELEME) 209 : IF(LISOUS(/1).NE.0) THEN 210 : DO 2 I=1,LISOUS(/1) 211 : IVAL=LISOUS(I) 211 : CALL AJOU(ITLAC,IVAL) 212 : 2 CONTINUE 213 : ENDIF 214 : else 214 : call quenom(cha8a) 215 : endif 216 : nosort(ks)=cha8a 217 : ISORTC(KS)=CTYP 218 : ISORTI(KS)=IRET 219 : GO TO 1 220 : 221 : C---- ON A EXPLORE TOUTES LES DEMANDES 222 : 100 CONTINUE 223 : LOBJ=ISORTI(/1) 224 : IF(LOBJ.lt.1.or.meleme.eq.0) then 224 : call erreur(1013) 225 : return 226 : endif 227 : * 228 : * traitement des demandes pour remplir completement 229 : * la liste des maillages avant de faire le tasspo 230 : * 231 : nbnn=1 232 : nbref=0 233 : nbsous=0 234 : nbchpo=0 235 : nbch=0 236 : segini lischp 237 : nbfach=0 238 : nbfa=0 239 : segini famchp 240 : do ia=1,lobj 241 : if(isortc(ia).eq.'CHPOINT') then 242 : nbch=nbch+1 243 : if(nbch.gt.nbchpo) then 244 : nbchpo=nbchpo+20 245 : segadj lischp 246 : endif 247 : mchpoi=isorti(ia) 248 : lichpo(nbch)=isorti(ia) 249 : nochpo(nbch)=nosort(ia) 250 : * on nomme tout de suite les objets maillage de profiles 251 : mchpoi=isorti(ia) 252 : segact mchpoi 253 : nbelem=0 254 : do ic=1,ipchp(/1) 255 : msoupo=ipchp(ic) 256 : segact msoupo 257 : ipt1=igeoc 258 : segact ipt1 259 : nbelem=IPT1.num(/2)+nbelem 260 : enddo 261 : segini ipt2 262 : ipt2.itypel=1 263 : ipp=0 264 : do ic=1,ipchp(/1) 265 : msoupo=ipchp(ic) 266 : ipt1=igeoc 267 : do iu=1,ipt1.num(/2) 268 : ipt2.num(1,iu+ipp)=ipt1.num(1,iu) 269 : enddo 270 : ipp=ipp+ipt1.num(/2) 271 : segdes msoupo,ipt1 272 : enddo 273 : nutemp=nutemp+1 274 : if(nutemp.lt.10) then 275 : write(notemp(8:8),fmt='(i1)')nutemp 276 : elseif(nutemp.le.100) then 277 : write(notemp(7:8),fmt='(i2)')nutemp 278 : elseif(nutemp.le.1000) then 279 : write(notemp(6:8),fmt='(i3)')nutemp 280 : elseif(nutemp.le.10000) then 281 : write(notemp(5:8),fmt='(i4)')nutemp 282 : else 283 : * write(6,*) ' coucou 10' 283 : call erreur (1014) 284 : return 285 : endif 286 : segdes ipt2 286 : call nomobj('MAILLAGE',notemp,ipt2) 287 : nosupp(nbch)=notemp 288 : lisgeo(nbch)=ipt2 289 : elseif(isortc(ia).eq.'TABLE') then 290 : * recherche des indices temps deplacement temperarures contraintes 291 : mtable=isorti(ia) 292 : itypk=' ' 292 : call acctab(mtable,'MOT ',ivalin,xvalin,'TEMPS', 293 : $ ilogin,iobjin,itypk,ivalin,xvalin,cha8a,ilogin,mtabte) 294 : * write(6,*) ' 1 itypk ' ,itypk 295 : if(itypk.eq.' ') then 296 : * write(6,*) ' coucou 11' 296 : call erreur (1014) 297 : return 298 : elseif(itypk.eq.'TABLE' )then 299 : itypk=' ' 300 : icachp=1 300 : call acctab(mtable,'MOT ',ivalin,xvalin,'DEPLACEMENTS', 301 : $ ilogin,iobjin,itypk,ivalin,xvalin,cha8a,ilogin,mtabde) 302 : * write(6,*) ' 2 itypk ' ,itypk 303 : if(itypk.eq.' ') then 304 : icachp=2 304 : call acctab(mtable,'MOT ',ivalin,xvalin, 305 : $ 'TEMPERATURES',ilogin,iobjin,itypk,ivalin,xvalin,cha8a, 306 : $ ilogin,mtabde) 307 : * write(6,*) ' 3 itypk ' ,itypk 308 : endif 309 : if( itypk.ne.'TABLE' ) then 310 : * write(6,*) ' coucou 12' 310 : call erreur (1014) 311 : return 312 : endif 313 : mtab1=mtabde 314 : mtab2=mtabte 315 : segact mtab1,mtab2 316 : do ib=1,mtab1.mlotab-1 317 : itypk=' ' 317 : call acctab(mtab2,'ENTIER ',ib,xva,cha8a,ilogin,iobjin, 318 : $ itypk,iu,dt,cha8a,ilogin,iobjre) 319 : itypk2=' ' 319 : call acctab(mtab1,'ENTIER ',ib,xva,cha8a,ilogin,iobjin, 320 : $ itypk2,iu,xva,cha8a,ilogin,iobchp) 321 : if(itypk.ne.'FLOTTANT'. or.itypk2.ne.'CHPOINT') then 322 : * write(6,*) ' coucou 13 ib ',ib 322 : call erreur (1014) 323 : return 324 : endif 325 : if(ib.eq.1) then 326 : nbfach=nbfach+1 327 : segadj famchp 328 : if(icachp.eq.1)nofamc(nbfach)='DEPLACEMENTS' 329 : if(icachp.eq.2)nofamc(nbfach)='TEMPERATURES' 330 : segact mtab2 331 : nbpas=mtab2.mlotab-1 332 : segini fachun 333 : nufach(nbfach)=fachun 334 : endif 335 : ifachp(ib)=iobchp 336 : fadt(ib)=dt 337 : ifanup(ib)=ib 338 : * on nomme tout de suite les objets maillage de profiles 339 : mchpoi=iobchp 340 : segact mchpoi 341 : nbref=0 342 : nbsous=0 343 : nbnn=1 344 : nbelem=0 345 : do ic=1,ipchp(/1) 346 : msoupo=ipchp(ic) 347 : segact msoupo 348 : ipt1=igeoc 349 : segact ipt1 350 : nbelem=IPT1.num(/2)+nbelem 351 : enddo 352 : segini ipt2 353 : ipt2.itypel=1 354 : ipp=0 355 : do ic=1,ipchp(/1) 356 : msoupo=ipchp(ic) 357 : ipt1=igeoc 358 : do iu=1,ipt1.num(/2) 359 : ipt2.num(1,iu+ipp)=ipt1.num(1,iu) 360 : enddo 361 : ipp=ipp+ipt1.num(/2) 362 : segdes msoupo,ipt1 363 : enddo 364 : nutemp=nutemp+1 365 : if(nutemp.lt.10) then 366 : write(notemp(8:8),fmt='(i1)')nutemp 367 : elseif(nutemp.le.100) then 368 : write(notemp(7:8),fmt='(i2)')nutemp 369 : elseif(nutemp.le.1000) then 370 : write(notemp(6:8),fmt='(i3)')nutemp 371 : elseif(nutemp.le.10000) then 372 : write(notemp(5:8),fmt='(i4)')nutemp 373 : else 374 : * write(6,*) ' coucou 14' 374 : call erreur (1014) 375 : return 376 : endif 377 : segdes ipt2 377 : call nomobj('MAILLAGE',notemp,ipt2) 378 : fanosu(ib)=notemp 379 : ifageo(ib)=ipt2 380 : enddo 381 : else 382 : * write(6,*) ' coucou 15' 382 : call erreur(1014) 383 : return 384 : endif 385 : elseif(isortc(ia).eq.'MAILLAGE') then 386 : else 387 : * write(6,*) ' coucou 16' 387 : call erreur (1014) 388 : return 389 : endif 390 : enddo 391 : * 392 : * on attaque la renumerotation 393 : * 394 : * write(6,*) ' appel a tasspo' ,(itlac(iou),iou=1,itlac(/1)) 394 : CALL TASSPO(ITLAC,icolac,ipt8,0) 395 : * write(6,*) ' sortie de tasspo' 396 : segini,ITLAC1=ITLAC 396 : CALL SUPPIL(ICOLAC,-1) 397 : ITLAC=ITLAC1 398 : segsup ipt8 399 : IF (IERR.NE.0) RETURN 400 : SEGACT MELEME 401 : IMAX=0 402 : * 403 : * on ecrit d'abord les maillages 404 : * 405 : imel=meleme 406 : * write(6,*) ' itlac(/1)',itlac(/1) 407 : do 6 iuy=1,itlac(/1) 408 : meleme=itlac(iuy) 409 : segact meleme 410 : DO 5 IK=1,MAX(1,LISOUS(/1)) 411 : IF (LISOUS(/1).NE.0)THEN 412 : IPT1=LISOUS(IK) 413 : SEGACT IPT1 414 : ELSE 415 : IPT1=MELEME 416 : ENDIF 417 : DO 3 J=1,IPT1.NUM(/2) 418 : DO 31 I=1,IPT1.NUM(/1) 419 : IMAX=MAX(IMAX,IPT1.NUM(I,J)) 420 : 31 CONTINUE 421 : 3 CONTINUE 422 : IF (LISOUS(/1).NE.0) SEGDES IPT1 423 : 5 CONTINUE 424 : 6 continue 425 : meleme=imel 426 : nno=imax 427 : * write(6,*) ' ecriture de ' , nno ,' noeuds' 428 : segini ixyz 429 : do i=1,nno 430 : do j=1,idim 431 : xyz(j,i)=xcoor( (i-1)*(idim+1) +j) 432 : enddo 433 : enddo 434 : * WRITE(*,*) 'Coucou : sauv.med' 435 : ILON=LONG(MEDSAU) 435 : CALL EFOUVR4(IFID,MEDSAU(1:ilon),MED_CREATION,ICRET) 436 : IF(ICRET.NE.0) THEN 437 : * WRITE(*,*) 'Erreur ouverture du fichier : sauv.med' 438 : ENDIF 438 : CALL EFMAAC4(IFID,NOBJ,IDIM,MED_NON_STRUCTURE,NOBJ,ICRET) 438 : call efespc4(ifid,nobj,idim,icret) 438 : CALL EFCOOE4(IFID,NOBJ,IDIM,xyz,MED_FULL_INTERLACE, 439 : & nno,MED_CART,MED_NOGAUSS,MED_NOGAUSS,ICRET) 440 : 441 : * 442 : * création des familles 443 : * 444 : segini icpr 445 : jg=100 446 : segini ijfam 447 : segini jsgtr 447 : call quidan(jsgtr,itlac,imax) 448 : C dans jsgtr liste des objets maillages 449 : ilong=jsgtr(/1) 449 : call repert('MAILLAGE',ititi) 449 : call replis('MAILLAGE',MLCHA8) 450 : segact mlcha8 451 : do 10 iou=1,ititi 451 : call lirobj('MAILLAGE',IOB,1,iretou) 452 : if(ierr.ne.0) return 453 : if(iob.eq.0) go to 10 454 : do 11 jou=1,ilong 455 : if(iob.eq.jsgtr(jou)) go to 12 456 : 11 continue 457 : go to 10 458 : 12 continue 459 : nomg=mlchar(iou) 459 : call disj(iob,icpr,ijfam,nomg) 460 : 10 continue 461 : 462 : 463 : * 464 : * famille des points 465 : * 466 : SEGINI nomnoe 466 : call repert('POINT ',ititi) 467 : if( ititi.ne.0) then 468 : kg=1 469 : segini nomg32 470 : * write(6,*) ' ititi ' , ititi 470 : call replis('POINT ',MLCHA8) 471 : segact mlcha8 472 : ineg=0 473 : do 110 iou=1,ititi 473 : call lirobj('POINT',IOB,1,iretou) 474 : if(ierr.ne.0) return 475 : if(iob.eq.0) go to 110 476 : * write(6,*) ' iob nnp', iob , nno 477 : if(iob.gt.nno) go to 110 478 : if(nomnoe(iob).ne.0) go to 110 479 : nogr32(1)=mlchar(iou) 480 : INEG=INEG-1 481 : nomnoe(iob)=INEG 482 : fobj(1:3)='FAP' 483 : iu=-ineg 484 : if( iu .lt.10)then 485 : ilong=4 486 : write(fobj(4:4),156) iu 487 : elseif(iu.lt.100) then 488 : ilong=5 489 : write(fobj(4:5),157) iu 490 : elseif(iu.lt.1000) then 491 : ilong=6 492 : write(fobj(4:6),158) iu 493 : elseif(iu.lt.10000) then 494 : ilong=7 495 : write(fobj(4:7),159) iu 496 : elseif(iu.lt.100000) then 497 : ilong=8 498 : write(fobj(4:8),160) iu 499 : else 499 : call erreur(19) 500 : return 501 : endif 502 : * write(6,*) ' nom du point ',nomg,' numero' , iob,ineg 502 : CALL EFFAMC4(IFID,NOBJ,FOBJ(1:ilong),INEG,0,0,0,0,nogr32(1), 503 : $ 1,ICRET,0,0) 504 : 110 continue 504 : CALL EFFAME4(IFID,NOBJ,nomnoe(1),nno,MED_NOEUD,0,ICRET,nomnoe(1)) 505 : endif 506 : SEGSUP nomnoe 507 : 508 : * 509 : * fabrication de la famille 0 et des numeros locaux d'elements dans la famille 0 510 : * 511 : iu=1 512 : nbsous=0 513 : nbref=0 514 : segini kfam 515 : do 50 iou=1,nfam 516 : ipt1=ifam(iou) 517 : segact ipt1 518 : itype=ipt1.itypel 519 : if( kfam(iou).eq.0) then 520 : ipt2=ipt1 521 : nbele=ipt2.num(/2) 522 : segini numlis 523 : do kou=1,nbele 524 : numlis(kou)=iu 525 : enddo 526 : 527 : nomgro=inogro(iou) 528 : segact nomgro 529 : kg=nogrou(/2) 530 : segini nomg32 531 : do mou=1,kg 532 : nogr32(mou)=nogrou(mou) 533 : enddo 534 : fobj(1:3)='FAM ' 535 : * write(6,*) ' famille ' ,i 536 : if( iu .lt.10)then 537 : ilong=4 538 : write(fobj(4:4),156) iu 539 : elseif(iu.lt.100) then 540 : ilong=5 541 : write(fobj(4:5),157) iu 542 : elseif(iu.lt.1000) then 543 : ilong=6 544 : write(fobj(4:6),158) iu 545 : elseif(iu.lt.10000) then 546 : ilong=7 547 : write(fobj(4:7),159) iu 548 : elseif(iu.lt.100000) then 549 : ilong=8 550 : write(fobj(4:8),160) iu 551 : else 551 : call erreur(19) 552 : return 553 : endif 554 : * WRITE(*,*) 'Ecriture ',FOBJ(1:ILONG),IU 554 : CALL EFFAMC4(IFID,NOBJ,FOBJ(1:ilong),iu,0,0,0,0,nogr32(1), 555 : & noco,ICRET,0,0) 556 : iu=iu+1 557 : ifam(iou)=1 558 : nbelei= nbele 559 : kfam(iou)=1 560 : else 561 : go to 50 562 : endif 563 : 564 : do jou=iou+1,nfam 565 : ipt3=ifam(jou) 566 : segact ipt3 567 : if(ipt3.itypel.eq.itype) then 568 : kfam(jou)=1 569 : nbnn=ipt2.num(/1) 570 : nbelem= ipt2.num(/2)+ipt3.num(/2) 571 : segadj ipt2 572 : do lou=1,ipt3.num(/2) 573 : do mou=1,nbnn 574 : ipt2.num(mou,lou+nbelei)= ipt3.num( mou,lou) 575 : enddo 576 : enddo 577 : nbele=ipt3.num(/2)+nbelei 578 : segadj numlis 579 : do lou=1,ipt3.num(/2) 580 : numlis(lou+nbelei)=iu 581 : enddo 582 : nbelei=nbele 583 : nomgro=inogro(jou) 584 : segact nomgro 585 : kg=nogrou(/2) 586 : segini nomg32 587 : do mou=1,kg 588 : nogr32(mou)=nogrou(mou) 589 : enddo 590 : fobj(1:3)='FAM' 591 : * write(6,*) ' famille ' ,i 592 : if( iu .lt.10)then 593 : ilong=4 594 : write(fobj(4:4),156) iu 595 : 156 format(i1) 596 : elseif(iu.lt.100) then 597 : ilong=5 598 : write(fobj(4:5),157) iu 599 : 157 format(i2) 600 : elseif(iu.lt.1000) then 601 : ilong=6 602 : write(fobj(4:6),158) iu 603 : 158 format(i3) 604 : elseif(iu.lt.10000) then 605 : ilong=7 606 : write(fobj(4:7),159) iu 607 : 159 format(i4) 608 : elseif(iu.lt.100000) then 609 : ilong=8 610 : write(fobj(4:8),160) iu 611 : 160 format(i5) 612 : else 612 : call erreur(19) 613 : return 614 : endif 615 : * WRITE(*,*) 'Ecriture ',FOBJ(1:ILONG),IU 615 : CALL EFFAMC4(IFID,NOBJ,FOBJ(1:ilong),iu,0,0,0,0,nogr32(1), 616 : & noco,ICRET,0,0) 617 : iu=iu+1 618 : endif 619 : enddo 620 : 621 : ITCELL=jcla(ipt2.itypel) 622 : iptanc=ipt2 623 : nvao=ipt2.num(/2)*ipt2.num(/1) 623 : call medtra(ipt2,1) 623 : CALL EFCONE4(IFID,NOBJ,medi(ipt2.itypel),ipt2.num, 624 : & MED_FULL_INTERLACE,ipt2.num(/2),MED_MAILLE,ITCELL, 625 : & MED_NOD,ICRET,ipt2.num,nvao) 626 : * write(6,*) ' sortie de efcone4 1' 626 : CALL EFFAME4(IFID,NOBJ,numlis(1),numlis(/1),MED_MAILLE, 627 : & ITCELL,ICRET,numlis(1)) 628 : * write(6,*) ' sortie de effame4 1' 629 : if(ipt2.ne.iptanc) segsup ipt2 630 : 50 continue 630 : CALL EFFAMC4(IFID,NOBJ,'FAM00',0,0,0,0,0,' ',0,ICRET,0,0) 631 : * write(6,*) ' sortie de effamc4 1' 632 : * 633 : * au tour des champpoint on commence par les chpoint isolés 634 : * 635 : do ia=1,nbch 636 : ipt1=lisgeo(ia) 637 : segact ipt1 638 : n=ipt1.num(/2) 639 : cha32a=nosupp(ia) 640 : * write(6,*) ' on veut creer le profil ', cha32a 640 : call efpfle4(ifid,ipt1.num,n,cha32a,icret,ipt1.num) 641 : if(icret.ne.0) then 642 : moterr(1:4)='MEDS' 643 : interr(1)=1 643 : call erreur(873) 644 : return 645 : endif 646 : segsup ipt1 646 : call nomobj('ANNULE ',cha32a,iiii) 647 : nbcom=100 648 : segini nocomm 649 : mchpoi=lichpo(ia) 650 : segact mchpoi 651 : nccc=0 652 : idej=0 653 : do ib=1,ipchp(/1) 654 : msoupo= ipchp(ib) 655 : segact msoupo 656 : if(ib.eq.1) then 657 : do ic=1,nocomp(/2) 658 : nocom(ic)(1:4)=nocomp(ic) 659 : enddo 660 : nccc=nocomp(/2) 661 : else 662 : do ic=1,nocomp(/2) 663 : do id=1,nccc 664 : if( nocomp(ic).eq.nocom(id)(1:4)) go to 745 665 : enddo 666 : nccc=nccc+1 667 : nocom(nccc)(1:4)=nocomp(ic) 668 : 745 continue 669 : enddo 670 : endif 671 : enddo 672 : nc=nccc 673 : segini mpova2 674 : do ib=1,ipchp(/1) 675 : msoupo=ipchp(ib) 676 : do ic=1,nocomp(/2) 677 : do id=1,nccc 678 : if( nocomp(ic).eq.nocom(id)(1:4)) then 679 : iposco(ic)=id 680 : go to 746 681 : endif 682 : enddo 683 : 746 continue 684 : enddo 685 : mpoval=ipoval 686 : segact mpoval 687 : do ie=1,nocomp(/2) 688 : id=iposco(ie) 689 : do ic=1,vpocha(/1) 690 : mpova2.vpocha(ic+idej,id)=vpocha(ic,ie) 691 : enddo 692 : enddo 693 : idej=idej+vpocha(/1) 694 : segdes msoupo,mpoval 695 : enddo 696 : cha32a=nochpo(ia) 697 : cha32b=nosupp(ia) 698 : * write(6,*) ' declaration dedu champ ', cha32a(1:8) 699 : * write(6,*) ' de composantes : ' ,(nocom(iou),iou=1,nccc) 699 : call efchac4(ifid,cha32a,6,nocom,cunit,nccc,icret) 700 : * write(6,*)' les 2 premieres valeurs associees sont :' 701 : * write(6,*) mpova2.vpocha(1,1),mpova2.vpocha(2,1) 702 : nccn=n*nccc 702 : call efchae4(ifid,nobj,cha32a,mpova2.vpocha,0,nccn,MED_NOGAUSS, 703 : 1 0,cha32b,2,3,0,1,' ', 704 : 1 0.d0,0,icret) 705 : segsup mpova2,nocomm 706 : 707 : segdes mchpoi 708 : enddo 709 : segsup lischp 710 : * 711 : * au tour des familles de champs 712 : * 713 : 714 : do ia=1, nbfach 715 : cha32a = nofamc(ia) 716 : fachun=nufach(ia) 717 : do ib=1,ifachp(/1) 718 : ipt1=ifageo(ib) 719 : segact ipt1 720 : n=ipt1.num(/2) 721 : cha32b=fanosu(ib) 722 : * write(6,*) ' on veut creer le profil ', cha32b 722 : call efpfle4(ifid,ipt1.num,n,cha32b,icret,ipt1.num) 723 : if(icret.ne.0) then 724 : moterr(1:4)='MEDS' 725 : interr(1)=1 725 : call erreur(873) 726 : return 727 : endif 728 : segsup ipt1 728 : call nomobj('ANNULE ',cha32b,iiii) 729 : nbcom=100 730 : segini nocomm 731 : mchpoi=ifachp(ib) 732 : segact mchpoi 733 : nccc=0 734 : idej=0 735 : do ie=1,ipchp(/1) 736 : msoupo= ipchp(ie) 737 : segact msoupo 738 : if(ie.eq.1) then 739 : do ic=1,nocomp(/2) 740 : nocom(ic)(1:16)=nocomp(ic) 741 : enddo 742 : nccc=nocomp(/2) 743 : * write(6,*)'ie nccc nocom ',ie,nccc,(nocom(iuy),iuy=1,nccc) 744 : else 745 : do ic=1,nocomp(/2) 746 : do id=1,nccc 747 : if( nocomp(ic).eq.nocom(id)(1:4)) go to 755 748 : enddo 749 : nccc=nccc+1 750 : nocom(nccc)(1:16)=nocomp(ic) 751 : * write(6,*)'ie nccc nocom ',ie,nccc,(nocom(iuy),iuy=1,nccc) 752 : 755 continue 753 : enddo 754 : endif 755 : enddo 756 : nc=nccc 757 : segini mpova2 758 : do ie=1,ipchp(/1) 759 : msoupo=ipchp(ie) 760 : do ic=1,nocomp(/2) 761 : do id=1,nccc 762 : if( nocomp(ic).eq.nocom(id)(1:4)) then 763 : iposco(ic)=id 764 : go to 756 765 : endif 766 : enddo 767 : 756 continue 768 : enddo 769 : mpoval=ipoval 770 : segact mpoval 771 : do ig=1,nocomp(/2) 772 : id=iposco(ig) 773 : do ic=1,vpocha(/1) 774 : mpova2.vpocha(ic+idej,id)=vpocha(ic,ig) 775 : enddo 776 : enddo 777 : idej=idej+vpocha(/1) 778 : segdes msoupo,mpoval 779 : enddo 780 : xpas=fadt(ib) 781 : nump=ifanup(ib) 782 : * write(6,*) ' declaration dedu champ ', cha32a(1:8) 783 : * write(6,*) ' de composantes : ' ,(nocom(iou),iou=1,nccc) 783 : call efchac4(ifid,cha32a,6,nocom,cunit,nccc,icret) 783 : call efchae4(ifid,nobj,cha32a,mpova2.vpocha,0,n*nccc, 784 : 1 MED_NOGAUSS,0,cha32b,2,3,0,nump,' ', 785 : 1 xpas,0,icret) 786 : segsup mpova2,nocomm 787 : segdes mchpoi 788 : enddo 789 : segsup fachun 790 : enddo 791 : segsup famchp 791 : CALL EFFERM4(IFID,ICRET) 792 : * write(6,*) ' sortie de meds!!!' 793 : IF(ICRET.NE.0) THEN 794 : moterr(1:4)='MEDS' 795 : interr(1)=1 795 : call erreur(873) 796 : ENDIF 797 : return 798 : end 799 : 800 : 801 : 802 : 803 :
© Cast3M 2003 - All rights reserved.
Disclaimer