1 : C KCOT SOURCE MAGN 10/05/18 21:15:33 6675 2 : SUBROUTINE KCOT 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8 (A-H,O-Z) 5 : C************************************************************************* 6 : C 7 : C OBJET : Cree un CHAMPOINT CENTRE contenant les informations 8 : C décrites ci dessous, sur les éléments du domaine. 9 : C 10 : C SYNTAXE : CHPC = KCOT OBJDOM ; 11 : C 12 : C OBJDOM : TABLE de SOUSTYPE DOMAINE 13 : C 14 : C AVIS IMPORTANT ; 15 : C 16 : C Ces informations sont destinées aux opérateurs de discrétisation 17 : C et sont rangées dans un ordre particulier. 18 : C 19 : C Les dimensions du tableau sont : (DIME NBEL) DIME=11 en 2D 20 : C DIME=13 en 3D 21 : C et il contient : 22 : C 23 : C pour un SEG2 la longueur de l'element (XML) et la matrice P(2,2) en 2D 24 : C P(3,3) en 3D 25 : C pour un TRI3 XML,XMH,AJ1/XML,AJ2/XML, et la matrice P(2,2) en 2D 26 : C P(3,3) en 3D 27 : C pour un QUA4 IDEM 28 : C pour un CUB8 XML XMH XME et la matrice P 29 : C pour un PRI6 IDEM 30 : C 31 : C*********************************************************************** 32 : C MATRICE P 33 : C LA MATRICE DE ROTATION DU REPERE GLOBALE VERS LE REPERE LOCAL 34 : C DEFINI PAR DEUX OU TROIS POINTS PRIS DANS XYZ SUIVANT QU'ON EST 35 : C EN 2D OU EN 3D 36 : C ON PREND P1 P2 ET PNP 37 : C 38 : C U TEL QUE T SOIT DIRIGE SUIVANT P1P2 V TOURNE VERS 39 : C . .V P1PNP ET U = T VECTORIEL V 40 : C . . 41 : C . . __ __ 42 : C (P1). . . . .T (P2) | tx ty tz | 43 : C | | 44 : C ON A ALORS WL= P WG P = | vx vy vz | 45 : C | | 46 : C | ux uy uz | 47 : C |__ __| 48 : C************************************************************************* 49 : -INC CCOPTIO 50 : -INC CCGEOME 51 : -INC SMTABLE 52 : -INC SMELEME 53 : POINTEUR MELEMC.MELEME 54 : -INC SMCOORD 55 : -INC SMCHPOI 56 : -INC SIZFFB 57 : PARAMETER (NLTS=8) 58 : CHARACTER*8 LISTS(NLTS) 59 : C*** 60 : REAL*8 AAJ(3,3,9),U,XC(3),T(13),XQ(81) 61 : PARAMETER (NTB=1) 62 : CHARACTER*8 LTAB(NTB),TYPE,NOM0,TYPC 63 : DIMENSION KTAB(NTB) 64 : DATA LTAB/'DOMAINE '/ 65 : DATA LISTS/'QUA4 ','CUB8 ','TRI3 ','PRI6 ','SEG2 ', 66 : &'SEG3 ','QUA9 ','TRI7 '/ 67 : C*** 68 : C write(6,*)' DBUT KCOT ' 69 : NTO=NTB 69 : CALL LITABS(LTAB,KTAB,NTB,NTO,IRET) 70 : IF (IERR.NE.0) RETURN 71 : MTABD=KTAB(1) 72 : 72 : CALL INITD(AAJ,81,0.D0) 73 : TYPE=' ' 73 : CALL ACMO(MTABD,'CENTRE',TYPE,MELEMC) 74 : IF(TYPE.NE.'MAILLAGE')GO TO 90 75 : 76 : IF(IDIM.EQ.2)NC=11 77 : IF(IDIM.EQ.3)NC=13 78 : 79 : TYPE='CENTRE' 79 : CALL CRCHPT(TYPE,MELEMC,NC,MCHPOI) 79 : CALL LICHT(MCHPOI,MPOVAL,TYPC,IGEOM) 80 : 81 : TYPE=' ' 81 : CALL ACMO(MTABD,'MAILLAGE',TYPE,MELEME) 82 : IF(TYPE.NE.'MAILLAGE')GO TO 90 83 : SEGACT MELEME 84 : 85 : IAXI=0 86 : IF(IFOMOD.EQ.0)IAXI=2 87 : NPGI=1 88 : 89 : NBSOUS=LISOUS(/1) 90 : IF(NBSOUS.EQ.0)NBSOUS=1 91 : 92 : K0=0 93 : DO 1 L=1,NBSOUS 94 : IPT1=MELEME 95 : IF(NBSOUS.NE.1)IPT1=LISOUS(L) 96 : SEGACT IPT1 97 : NP=IPT1.NUM(/1) 98 : NEL=IPT1.NUM(/2) 99 : NOM0=NOMS(IPT1.ITYPEL)//' ' 99 : CALL OPTLI(IP,LISTS,NOM0,NLTS) 100 : IF(IP.EQ.0)THEN 101 : WRITE(6,*)' Il y a des types d''éléments pour lesquels on ne sait' 102 : &,'pas faire' 103 : GO TO 1 104 : ENDIF 104 : CALL KALPBG(NOM0,'FONFORM ',IZFFM) 105 : SEGACT IZFFM*MOD 106 : IZHR=KZHR(1) 107 : SEGACT IZHR*MOD 108 : NES=GR(/1) 109 : NPG=GR(/3) 110 : 111 : DO 10 K=1,NEL 112 : KK=K0+K 113 : NPGR=0 114 : IF(IAXI.NE.0)NPGR=NPG 115 : C 116 : C REMPLISSAGE DE XYZ 117 : C ------------------ 118 : C 119 : DO 12 I=1,NP 120 : J=IPT1.NUM(I,K) 121 : DO 12 N=1,IDIM 122 : XYZ(N,I)=XCOOR((J-1)*(IDIM+1)+N) 123 : 12 CONTINUE 124 : 125 : IF(IP.EQ.6)THEN 126 : IN=0 127 : DO 13 I=1,NP,2 128 : J=IPT1.NUM(I,K) 129 : DO 13 N=1,IDIM 130 : IN=IN+1 131 : XQ(IN)=XCOOR((J-1)*(IDIM+1)+N) 132 : 13 CONTINUE 133 : ELSEIF(IP.GT.6)THEN 134 : IN=0 135 : DO 14 I=1,NP-1,2 136 : J=IPT1.NUM(I,K) 137 : DO 14 N=1,IDIM 138 : IN=IN+1 139 : XQ(IN)=XCOOR((J-1)*(IDIM+1)+N) 140 : 14 CONTINUE 141 : ENDIF 142 : 142 : IF(IP.LE.5)CALL CALJAJ(GR,XYZ,NES,IDIM,NP,NPGI,AAJ) 143 : C 143 : CALL CALJBC(FN,GR,PG,XYZ,HR,PGSQ,RPG,NES,IDIM,NP,NPG,IAXI,AIRE) 144 : 145 : IF(AIRE.LE.0)AIRE=ABS(AIRE) 146 : 147 : 148 : C CALCUL DES LONGUEURS DES COTES DE L'ELEMENT 149 : C UNIQUEMENT POUR LES SEG2 QUA4 ET CUB8 150 : 151 : XML=0.D0 152 : DO 231 N=1,IDIM 153 : XML=XML+(XYZ(N,1)-XYZ(N,2))*(XYZ(N,1)-XYZ(N,2)) 154 : 231 CONTINUE 155 : XML=SQRT(XML) 156 : C 157 : C 158 : IF(XML.EQ.0.D0) 159 : &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) ' 160 : C 161 : C 162 : IF(NOM0.EQ.'SEG2 ')THEN 163 : T(1)=XML 163 : CALL CALJQB(XYZ,T(5),IDIM,IDIM) 164 : GOTO 244 165 : ELSEIF(NOM0.EQ.'SEG3 ')THEN 166 : T(1)=XML 166 : CALL CALJQB(XQ,T(5),IDIM,IDIM) 167 : GOTO 244 168 : ENDIF 169 : C 170 : C 171 : XMH=0.D0 172 : DO 232 N=1,IDIM 173 : XMH=XMH+(XYZ(N,2)-XYZ(N,3))*(XYZ(N,2)-XYZ(N,3)) 174 : 232 CONTINUE 175 : XMH=SQRT(XMH) 176 : C WRITE(6,*)'........XML XMH NP NES ',XML,XMH,NP,NES 177 : 178 : C 179 : C 180 : IF(XMH.EQ.0.D0) 181 : &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) ' 182 : C 183 : C 184 : 185 : IF(NOM0.EQ.'QUA4 '.OR.NOM0.EQ.'TRI3 ')THEN 186 : T(1)=XML 187 : T(2)=XMH 188 : T(3)=AAJ(1,1,1)/XML 189 : T(4)=AAJ(2,1,1)/XML 189 : CALL CALJQB(XYZ,T(5),IDIM,IDIM) 190 : GOTO 244 191 : ELSEIF(NOM0.EQ.'QUA9 '.OR.NOM0.EQ.'TRI7 ')THEN 192 : T(1)=XML 193 : T(2)=XMH 194 : T(3)=AAJ(1,1,1)/XML 195 : T(4)=AAJ(2,1,1)/XML 195 : CALL CALJQB(XQ,T(5),IDIM,IDIM) 196 : GOTO 244 197 : ENDIF 198 : 199 : IF(NOM0.EQ.'CUB8 '.OR.NOM0.EQ.'PRI6 ')THEN 200 : 201 : XME=0.D0 202 : IF(NOM0.EQ.'CUB8 ')THEN 203 : DO 242 N=1,IDIM 204 : XME=XME+(XYZ(N,1)-XYZ(N,5))*(XYZ(N,1)-XYZ(N,5)) 205 : 242 CONTINUE 206 : ENDIF 207 : 208 : IF(NOM0.EQ.'PRI6 ')THEN 209 : DO 243 N=1,IDIM 210 : XME=XME+(XYZ(N,1)-XYZ(N,4))*(XYZ(N,1)-XYZ(N,4)) 211 : 243 CONTINUE 212 : ENDIF 213 : 214 : XME=SQRT(XME) 215 : C WRITE(6,*)'........XML XMH XME NP NES ',XML,XMH,XME,NP,NES 216 : C 217 : IF(XME.EQ.0.D0) 218 : &WRITE(6,*)' ELEMENT DEGENERE ( AYANT UN COTE DE LONGUEUR NULLE) ' 219 : C 220 : C 220 : CALL CALJQB(XYZ,T(5),IDIM,4) 221 : T(1)=XML 222 : T(2)=XMH 223 : T(3)=XME 224 : GO TO 244 225 : ENDIF 226 : 227 : 244 CONTINUE 228 : 228 : CALL RSETIV(VPOCHA,NC,KK,T,NC) 229 : 230 : C write(6,*)' KK=',KK 231 : C write(6,1002)T 232 : 10 CONTINUE 233 : K0=K0+NEL 234 : SEGDES IPT1 235 : 1 CONTINUE 236 : SEGDES MELEME,MPOVAL,MCHPOI 237 : C 237 : CALL ECROBJ('CHPOINT ',MCHPOI) 238 : 239 : C write(6,*)' FIN KCOT ' 240 : RETURN 241 : 242 : 90 CONTINUE 243 : WRITE(6,*)' Interruption anormale de KCOT' 244 : C Option %m1:8 incompatible avec les données 244 : CALL ERREUR(803) 245 : RETURN 246 : 1001 FORMAT(20(1X,I5)) 247 : 1002 FORMAT(10(1X,1PE11.4)) 248 : END 249 : 250 : 251 : 252 : 253 : 254 :
© Cast3M 2003 - All rights reserved.
Disclaimer