1 : C CRECTR SOURCE CHAT 05/01/12 22:29:02 5004 2 : SUBROUTINE CRECTR 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************* 6 : C 7 : C OBJET : Cree un point au centre de gravite des éléments d'un maillage 8 : C (On ignore si ce point existe déja dans le cas d'éléments quadratiques) 9 : C SYNTAXE : OBJ2 = KCTR OBJ1 <'INCL' TABDOM> ; 10 : C 11 : C OBJ1 : objet 'MAILLAGE' 12 : C OBJ2 : objet 'MAILLAGE' constitué d'éléments POI1 13 : C 14 : C************************************************************************* 15 : -INC SMELEME 16 : POINTEUR MP1.MELEME 17 : POINTEUR MELEMC.MELEME,MELEF1.MELEME 18 : -INC SMTABLE 19 : POINTEUR MTABD.MTABLE 20 : -INC SMCOORD 21 : -INC CCOPTIO 22 : CHARACTER*4 LISMO(1) 23 : PARAMETER (NTB=1) 24 : DIMENSION KTAB(NTB) 25 : CHARACTER*8 LTAB(NTB),TYPE 26 : DATA LISMO /'INCL'/ 27 : DATA LTAB /'DOMAINE '/ 28 : 29 : C*** 30 : 30 : CALL LIROBJ('MAILLAGE',MELEME,1,IRET) 31 : IF(IRET.EQ.0)RETURN 32 : 33 : KINC=0 33 : CALL LIRMOT(LISMO,1,IP,0) 34 : IF(IP.NE.0)THEN 35 : KINC=1 36 : NTO=1 36 : CALL LITABS(LTAB,KTAB,NTB,NTO,IRET) 37 : IF(IRET.EQ.0)RETURN 37 : CALL LIRREE(XVAL,1,IRET) 38 : IF(IRET.EQ.0)RETURN 39 : MTABD=KTAB(1) 40 : TYPE=' ' 40 : CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC) 40 : C call ecrobj('MAILLAGE',MELEMC) 41 : IF(TYPE.NE.'MAILLAGE')RETURN 42 : TYPE=' ' 42 : CALL ACMO(MTABD,'FACE',TYPE,MELEF1) 43 : ENDIF 44 : 44 : CALL KNBEL(MELEME,NELN) 45 : 46 : NBPTI=XCOOR(/1)/(IDIM+1) 47 : NBPTS=NBPTI+NELN 48 : SEGADJ MCOORD 49 : 50 : NBSOUS=0 51 : NBREF=0 52 : NBNN=1 53 : NBELEM=NELN 54 : SEGINI MP1 55 : MP1.ITYPEL=1 56 : SEGACT MELEME 57 : NBSOUS=LISOUS(/1) 58 : IF(NBSOUS.EQ.0)NBSOUS=1 59 : K0=0 60 : 61 : DO 1 L=1,NBSOUS 62 : IF(NBSOUS.NE.1)THEN 63 : IPT1=LISOUS(L) 64 : SEGACT IPT1 65 : ELSE 66 : IPT1=MELEME 67 : ENDIF 68 : NP=IPT1.NUM(/1) 69 : NEL=IPT1.NUM(/2) 70 : 71 : IF(IDIM.EQ.2)THEN 72 : DO 2 K=1,NEL 73 : NK=K0+K 74 : XC=0.D0 75 : YC=0.D0 76 : DO 21 I=1,NP 77 : IP=IPT1.NUM(I,K) 78 : XC=XC+XCOOR((IP-1)*(IDIM+1)+1) 79 : YC=YC+XCOOR((IP-1)*(IDIM+1)+2) 80 : 21 CONTINUE 81 : XC=XC/DBLE(NP) 82 : YC=YC/DBLE(NP) 83 : XD=XCOOR(IP*(IDIM+1)) 84 : 85 : IP=NBPTI+NK 86 : XCOOR((IP-1)*(IDIM+1)+1)=XC 87 : XCOOR((IP-1)*(IDIM+1)+2)=YC 88 : XCOOR(IP*(IDIM+1))=XD 89 : MP1.NUM(1,NK)=IP 90 : 91 : 2 CONTINUE 92 : 93 : 94 : ELSEIF(IDIM.EQ.3)THEN 95 : DO 3 K=1,NEL 96 : NK=K0+K 97 : XC=0.D0 98 : YC=0.D0 99 : ZC=0.D0 100 : DO 31 I=1,NP 101 : IP=IPT1.NUM(I,K) 102 : XC=XC+XCOOR((IP-1)*(IDIM+1)+1) 103 : YC=YC+XCOOR((IP-1)*(IDIM+1)+2) 104 : ZC=ZC+XCOOR((IP-1)*(IDIM+1)+3) 105 : 31 CONTINUE 106 : XC=XC/DBLE(NP) 107 : YC=YC/DBLE(NP) 108 : ZC=ZC/DBLE(NP) 109 : XD=XCOOR(IP*(IDIM+1)) 110 : 111 : IP=NBPTI+NK 112 : XCOOR((IP-1)*(IDIM+1)+1)=XC 113 : XCOOR((IP-1)*(IDIM+1)+2)=YC 114 : XCOOR((IP-1)*(IDIM+1)+3)=ZC 115 : XCOOR(IP*(IDIM+1))=XD 116 : MP1.NUM(1,NK)=IP 117 : 118 : 3 CONTINUE 119 : ENDIF 120 : K0=K0+NEL 121 : IF(NBSOUS.NE.1)THEN 122 : SEGDES IPT1 123 : ENDIF 124 : 1 CONTINUE 125 : SEGDES MELEME 126 : IF(KINC.NE.0)THEN 127 : WRITE(6,1951)NELN 128 : 1951 FORMAT(1X,'KCTR : Creation des points centre :', 129 : & ' Nombre de points a eliminer :',I7) 129 : CALL ECMO(MTABD,'BIDON','MAILLAGE',MP1) 129 : CALL ECRREE(XVAL) 129 : CALL ECROBJ('MAILLAGE',MELEMC) 129 : CALL ECROBJ('MAILLAGE',MP1 ) 129 : CALL PRELIM(0) 129 : CALL LIROBJ('MAILLAGE',IP,1,IRET) 130 : C write(6,*)' Retour prelim melemc,mp1,ip=',melemc,mp1,ip 131 : IF(MELEF1.NE.0)THEN 132 : WRITE(6,*)' Elimination avec les faces' 132 : CALL ECRREE(XVAL) 132 : CALL ECROBJ('MAILLAGE',MELEF1) 132 : CALL ECROBJ('MAILLAGE',MP1) 132 : CALL PRELIM(0) 132 : CALL LIROBJ('MAILLAGE',IP,1,IRET) 133 : C write(6,*)' Retour prelim melemc,mp1,ip=',melemc,mp1,ip 134 : ENDIF 135 : ELSE 136 : C Car normalement, ELIM a sans doute desactive MP1 137 : SEGDES MP1 138 : ENDIF 138 : CALL ECROBJ('MAILLAGE',MP1) 139 : RETURN 140 : 141 : END 142 : 143 : 144 :
© Cast3M 2003 - All rights reserved.
Disclaimer