1 : C TASSPO SOURCE PV 12/12/06 21:15:33 7594 2 : C CE SOUS PROGRAMME A POUR DESSEIN D'ELIMINER DE LA MEMOIRE LES POINTS 3 : C NE POUVANT PLUS ETRE UTILISES. 4 : C 5 : SUBROUTINE TASSPO(ITLAC,ICOLAC,MELEME,mena) 6 : IMPLICIT INTEGER(I-N) 7 : -INC CCOPTIO 8 : -INC CCGEOME 9 : -INC CCNOYAU 10 : -INC SMCOORD 11 : -INC SMELEME 12 : -INC CCASSIS 13 : SEGMENT ITLAC(0) 14 : CHARACTER*2 CARBID 15 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 16 : IF (LMNNOM.EQ.0) RETURN 17 : * nomlu est manipule par tassp2 via repert et ecpi 18 : * NOMLUS=NOMLU 19 : * POUR ETRE SUR QU'IL Y A UN ELEMENT DANS ITLAC 20 : if(nbesc.ne.0) segact ipiloc 21 : DO 30 I=1,LMNNOM 22 : IF (INOOB2(I).NE.'MAILLAGE') GOTO 30 23 : IP=INOOB1(I) 24 : IDEBCH=IPCHAR(IP) 25 : IFINCH=IPCHAR(IP+1)-1 26 : IF (ICHARA(IDEBCH:IFINCH).EQ.' ') GOTO 30 27 : MELEME=IOUEP2(I) 28 : IF (MELEME.EQ.0) GOTO 30 29 : SEGACT MELEME 30 : if (itypel.eq.22) goto 30 31 : IF( LISOUS(/1).EQ.0.AND.NUM(/2).EQ.0) go to 30 31 : CALL AJOU(ITLAC,MELEME) 32 : GOTO 31 33 : 30 CONTINUE 34 : 31 CONTINUE 35 : if(nbesc.ne.0) segdes ipiloc 36 : segact mcoord 37 : SEGINI ICPR 38 : ICDOUR=0 39 : DO 1 I=1,ICPR(/1) 40 : 1 ICPR(I)=0 41 : if (itlac(/1).ne.0) THEN 42 : i1=0 43 : do iv=1,itlac(/1) 44 : IVAL=ITLAC(iv) 45 : *SG Conformément à ce qui est fait dans assem1 et asns1, il 46 : *SG faut créer un MELEME identique à IVAL dont le premier LISOUS 47 : *SG est un point quelconque (non multiplicateur de Lagrange) 48 : *SG de IVAL 49 : ipt1=ival 50 : ipt3=ipt1 51 : segact ipt1 52 : nbsou1=max(1,ipt1.lisous(/1)) 53 : do isou=1,nbsou1 54 : if (ipt1.lisous(/1).ne.0) ipt3=ipt1.lisous(isou) 55 : segact ipt3 56 : if (ipt3.itypel.ne.22.AND.ipt3.num(/2).ne.0) then 57 : i1=ipt3.num(1,1) 58 : goto 4865 59 : endif 60 : enddo 61 : enddo 62 : 4865 continue 62 : if (i1.EQ.0) call erreur(5) 63 : nbsous=0 64 : nbnn=1 65 : nbref=0 66 : nbelem=1 67 : segini meleme 68 : itypel=1 69 : num(1,1)=i1 70 : segdes meleme 71 : imelp=meleme 72 : nbsous=nbsou1+1 73 : nbref=0 74 : nbnn=0 75 : nbelem=0 76 : segini meleme 77 : lisous(1)=imelp 78 : ipt3=ipt1 79 : do isou=1,nbsou1 80 : if (ipt1.lisous(/1).ne.0) ipt3=ipt1.lisous(isou) 81 : lisous(isou+1)=ipt3 82 : segdes ipt3 83 : enddo 84 : segdes meleme 85 : ival=meleme 85 : CALL NUMOPT(IVAL,ICPR,ICDOUR) 86 : ELSE 87 : * lecture de noop qui est systematiquement mis par menage 87 : call lircha(carbid,0,iretou) 88 : if(iretou.eq.0) write(6,*) ' erreur inattendu tasspo' 89 : ENDIF 89 : CALL TASSP2(ITLAC,ICPR,ICDOUR,icolac,mena) 90 : * NOMLU=NOMLUS 91 : * creation du maillage resultat 92 : nbnn=1 93 : nbelem=icpr(/1) 94 : nbref=0 95 : nbsous=0 96 : segini meleme 97 : ipt=0 98 : do 100 ip=1,nbelem 99 : icp=icpr(ip) 100 : if (icp.ne.0) then 101 : ipt=ipt+1 102 : num(1,ipt)=icp 103 : icolor(ipt)=idcoul 104 : endif 105 : 100 continue 106 : nbelem=ipt 107 : segadj meleme 108 : itypel=1 109 : segsup icpr 110 : RETURN 111 : END 112 : 113 : 114 : 115 : 116 : 117 :
© Cast3M 2003 - All rights reserved.
Disclaimer