1 : C ORIENT SOURCE GOUNAND 08/06/09 21:15:11 6122 2 : C CET OPERATEUR ORIENTE LES ELEMENTS ORIENTABLES EN FONCTION DE XP 3 : C 4 : SUBROUTINE ORIENT(IPT1,IPT2,XP,ICLE) 5 : * 6 : * ICLE=1 ORIEN DIRE 7 : * ICLE=2 ORIEN POINT 8 : * 9 : IMPLICIT INTEGER(I-N) 10 : IMPLICIT REAL*8 (A-H,O-z) 11 : DIMENSION XP(3) 12 : DIMENSION XQ(3) 13 : LOGICAL LQUAF 14 : -INC CCREEL 15 : -INC SMELEME 16 : -INC CCGEOME 17 : -INC CCOPTIO 18 : -INC SMCOORD 18 : IF (ICLE.NE.1.AND.ICLE.NE.2) CALL ERREUR(5) 19 : IF (ICLE.EQ.1) THEN 20 : * NORMALISATION DU VECTEUR 21 : DP=SQRT(XP(1)**2+XP(2)**2+XP(3)**2) 22 : IF (DP.LE.XPETIT) THEN 22 : CALL ERREUR(277) 23 : DP=1.D0 24 : ENDIF 25 : XQ(1)=XP(1)/DP 26 : XQ(2)=XP(2)/DP 27 : XQ(3)=XP(3)/DP 28 : ENDIF 29 : NBREF=IPT1.LISREF(/1) 30 : NBSOUS=0 31 : NBELEM=IPT1.NUM(/2) 32 : NBNN=IPT1.NUM(/1) 33 : ITYP=KSURF(IPT1.ITYPEL) 34 : IF (ITYP.NE.0.AND.ITYP.EQ.IPT1.ITYPEL) GOTO 1 35 : * ce n'est pas des éléments de surface 36 : * est-on en présence de cub8 (shb8) 37 : * 38 : if(ipt1.itypel.eq.14) then 39 : nbref=2 40 : segini ipt2 41 : nbnn=4 42 : nbref=0 43 : segini ipt3,ipt4 44 : ipt2.lisref(1)=ipt3 45 : ipt2.lisref(2)=ipt4 46 : ipt3.itypel=8 47 : ipt4.itypel=8 48 : ipt2.itypel=14 49 : idim1=idim+1 50 : do i=1,ipt1.num(/2) 51 : ia=ipt1.num(1,i) - 1 52 : ib=ipt1.num(5,i) - 1 53 : ic=ipt1.num(2,i) - 1 54 : id=ipt1.num(3,i) - 1 55 : xab=xcoor(ib*idim1+1)-xcoor(ia*idim1+1) 56 : yab=xcoor(ib*idim1+2)-xcoor(ia*idim1+2) 57 : zab=xcoor(ib*idim1+3)-xcoor(ia*idim1+3) 58 : xac=xcoor(ic*idim1+1)-xcoor(ia*idim1+1) 59 : yac=xcoor(ic*idim1+2)-xcoor(ia*idim1+2) 60 : zac=xcoor(ic*idim1+3)-xcoor(ia*idim1+3) 61 : xad=xcoor(id*idim1+1)-xcoor(ia*idim1+1) 62 : yad=xcoor(id*idim1+2)-xcoor(ia*idim1+2) 63 : zad=xcoor(id*idim1+3)-xcoor(ia*idim1+3) 64 : xpvec= yac*zad - zac*yad 65 : ypvec= zac*xad - xac*zad 66 : zpvec= xac*yad - yac*xad 67 : pmix=xpvec*xab+ypvec*yab+zpvec*zab 68 : isens=0 69 : if(pmix.ge.0.d0) isens=1 70 : if(icle.eq.1) then 71 : xsc=xab*xq(1)+yab*xq(2)+zab*xq(3) 72 : else 73 : xsc= xab*(xq(1)-xcoor(ib*idim1+1))+ 74 : $ yab*(xq(2)-xcoor(ib*idim1+2))+ 75 : $ zab*(xq(3)-xcoor(ib*idim1+3)) 76 : endif 77 : if(xsc.ge.0.d0) then 78 : do j=1,8 79 : ipt2.num(j,i)=ipt1.num(j,i) 80 : enddo 81 : if(isens.eq.2) then 82 : iu=ipt2.num(2,i) 83 : ipt2.num(2,i)=ipt2.num(4,i) 84 : ipt2.num(4,i)=iu 85 : iu=ipt2.num(6,i) 86 : ipt2.num(6,i)=ipt2.num(8,i) 87 : ipt2.num(8,i)=iu 88 : endif 89 : else 90 : ipt2.num(1,i)=ipt1.num(5,i) 91 : ipt2.num(2,i)=ipt1.num(8,i) 92 : ipt2.num(3,i)=ipt1.num(7,i) 93 : ipt2.num(4,i)=ipt1.num(6,i) 94 : ipt2.num(5,i)=ipt1.num(1,i) 95 : ipt2.num(6,i)=ipt1.num(4,i) 96 : ipt2.num(7,i)=ipt1.num(3,i) 97 : ipt2.num(8,i)=ipt1.num(2,i) 98 : if(isens.eq.2) then 99 : iu=ipt2.num(2,i) 100 : ipt2.num(2,i)=ipt2.num(4,i) 101 : ipt2.num(4,i)=iu 102 : iu=ipt2.num(6,i) 103 : ipt2.num(6,i)=ipt2.num(8,i) 104 : ipt2.num(8,i)=iu 105 : endif 106 : endif 107 : ipt2.icolor(i)=ipt1.icolor(i) 108 : ipt3.num(1,i)=ipt2.num(1,i) 109 : ipt3.num(2,i)=ipt2.num(2,i) 110 : ipt3.num(3,i)=ipt2.num(3,i) 111 : ipt3.num(4,i)=ipt2.num(4,i) 112 : ipt3.icolor(i)=ipt2.icolor(i) 113 : ipt4.num(1,i)=ipt2.num(5,i) 114 : ipt4.num(2,i)=ipt2.num(6,i) 115 : ipt4.num(3,i)=ipt2.num(7,i) 116 : ipt4.num(4,i)=ipt2.num(8,i) 117 : ipt4.icolor(i)=ipt2.icolor(i) 118 : enddo 119 : segdes ipt3,ipt4 120 : return 121 : endif 122 : IPT2=IPT1 123 : RETURN 124 : * 125 : * on a des vrais éléments de surfaces 126 : * 127 : 1 CONTINUE 128 : * Cas QUAF TRI7 ou QUA9 129 : LQUAF=(ITYP.EQ.11.OR.ITYP.EQ.7) 130 : SEGINI IPT2 131 : IPT2.ITYPEL=ITYP 132 : IF (NBREF.EQ.0) GOTO 3 133 : DO 2 I=1,NBREF 134 : IPT2.LISREF(I)=IPT1.LISREF(I) 135 : 2 CONTINUE 136 : 3 CONTINUE 137 : SEGACT MCOORD 138 : IB=NSPOS(ITYP)-1 139 : IS1=IBSOM(IB+1) 140 : IS2=IBSOM(IB+2) 141 : IS3=IBSOM(IB+3) 142 : 143 : 144 : DO 4 J=1,NBELEM 145 : IP1=IPT1.NUM(IS1,J) 146 : IP2=IPT1.NUM(IS2,J) 147 : IP3=IPT1.NUM(IS3,J) 148 : IREF1=(IDIM+1)*(IP1-1) 149 : IREF2=(IDIM+1)*(IP2-1) 150 : IREF3=(IDIM+1)*(IP3-1) 151 : XV1=XCOOR(IREF2+1)-XCOOR(IREF1+1) 152 : YV1=XCOOR(IREF2+2)-XCOOR(IREF1+2) 153 : ZV1=XCOOR(IREF2+3)-XCOOR(IREF1+3) 154 : IF (IDIM.NE.3) ZV1=0.D0 155 : XV2=XCOOR(IREF2+1)-XCOOR(IREF3+1) 156 : YV2=XCOOR(IREF2+2)-XCOOR(IREF3+2) 157 : ZV2=XCOOR(IREF2+3)-XCOOR(IREF3+3) 158 : IF (IDIM.NE.3) ZV2=0.D0 159 : XV3=ZV1*YV2-ZV2*YV1 160 : YV3=XV1*ZV2-XV2*ZV1 161 : ZV3=YV1*XV2-YV2*XV1 162 : XVN=SQRT(XV3**2+YV3**2+ZV3**2) 163 : IF (ICLE.EQ.2) THEN 164 : XQ(1)=0.D0 165 : XQ(2)=0.D0 166 : XQ(3)=0.D0 167 : DO 10 L=1,NBNN 168 : IREF=(IPT1.NUM(L,J)-1)*(IDIM+1) 169 : DO 11 K=1,3 170 : XQ(K)=XQ(K)+XCOOR(IREF+K) 171 : 11 CONTINUE 172 : 10 CONTINUE 173 : XQ(1)=XQ(1)/NBNN 174 : XQ(2)=XQ(2)/NBNN 175 : XQ(3)=XQ(3)/NBNN 176 : XQ(1)=XP(1)-XQ(1) 177 : XQ(2)=XP(2)-XQ(2) 178 : XQ(3)=XP(3)-XQ(3) 179 : DP=SQRT(XQ(1)**2+XQ(2)**2+XQ(3)**2) 180 : IF (DP.LE.XPETIT) THEN 180 : CALL ERREUR(277) 181 : DP=1.D0 182 : ENDIF 183 : XQ(1)=XQ(1)/DP 184 : XQ(2)=XQ(2)/DP 185 : XQ(3)=XQ(3)/DP 186 : ENDIF 187 : TEST=XV3*XQ(1)+YV3*XQ(2)+ZV3*XQ(3) 187 : IF (ABS(TEST).LE.0.0175D0*XVN) CALL ERREUR(278) 188 : IF (TEST.GE.0.D0) THEN 189 : DO 6 I=1,NBNN 190 : IPT2.NUM(I,J)=IPT1.NUM(I,J) 191 : 6 CONTINUE 192 : ELSE 193 : IF (.NOT.LQUAF) THEN 194 : DO 7 I=1,NBNN 195 : IPT2.NUM(MOD(NBNN+1-I,NBNN)+1,J)=IPT1.NUM(I,J) 196 : 7 CONTINUE 197 : ELSE 198 : NBNN1=NBNN-1 199 : DO 8 I=1,NBNN1 200 : IPT2.NUM(MOD(NBNN1+1-I,NBNN1)+1,J)=IPT1.NUM(I,J) 201 : 8 CONTINUE 202 : IPT2.NUM(NBNN,J)=IPT1.NUM(NBNN,J) 203 : ENDIF 204 : ENDIF 205 : IPT2.ICOLOR(J)=IPT1.ICOLOR(J) 206 : 4 CONTINUE 207 : RETURN 208 : END 209 : 210 : 211 : 212 : 213 : 214 : 215 : 216 : 217 : 218 : 219 : 220 : 221 :
© Cast3M 2003 - All rights reserved.
Disclaimer