1 : C PROMOD SOURCE CHAT 05/01/13 02:33:41 5004 2 : C PROJECTION SPECIALE POUR MODI 3 : SUBROUTINE PROMOD(ICPR,XPROJ,IOEIL,ICLE,IBOUJ) 4 : IMPLICIT INTEGER(I-N) 5 : -INC SMCOORD 6 : -INC CCOPTIO 7 : SEGMENT ICPR(0) 8 : SEGMENT IBOUJ(ITE) 9 : SEGMENT XPROJ(3,0) 10 : DIMENSION XBAR(3),OEIL(3),XMAT(3,3),XINT(3),YINT(3) 11 : SAVE XBAR,XMAT,RPREC 12 : ITE=ICPR(/1) 13 : SEGADJ IBOUJ 14 : IF (ICLE.NE.1) GOTO 100 15 : IF (IDIM.EQ.2) THEN 16 : DO 10 I=1,ICPR(/1) 17 : IP=ICPR(I) 18 : IF (IP.EQ.0) GOTO 10 19 : IREF=(IDIM+1)*(I-1) 20 : DO 20 J=1,2 21 : XPROJ(J,IP)=XCOOR(IREF+J) 22 : 20 CONTINUE 23 : XPROJ(J,IP)=0. 24 : 10 CONTINUE 25 : RETURN 26 : ENDIF 27 : * CALCUL DE LA MATRICE DE PROJECTION 28 : * RECHERCHE DU BARYCENTRE GENERAL 29 : RPREC=0. 30 : XBAR(1)=0. 31 : XBAR(2)=0. 32 : XBAR(3)=0. 33 : NP=0 34 : DO 30 I=1,ICPR(/1) 35 : IP=ICPR(I) 36 : IF (IP.EQ.0) GOTO 30 37 : NP=NP+1 38 : IREF=(IDIM+1)*(I-1) 39 : DO 50 J=1,3 40 : XXX=XCOOR(IREF+J) 41 : RPREC=MAX(RPREC,ABS(XXX)) 42 : XBAR(J)=XXX+XBAR(J) 43 : 50 CONTINUE 44 : 30 CONTINUE 45 : RPREC=RPREC*1E-5 46 : XBAR(1)=XBAR(1)/NP 47 : XBAR(2)=XBAR(2)/NP 48 : XBAR(3)=XBAR(3)/NP 49 : * OEIL 50 : IREF=(IDIM+1)*(IOEIL-1) 51 : OEIL(1)=XCOOR(IREF+1) 52 : OEIL(2)=XCOOR(IREF+2) 53 : OEIL(3)=XCOOR(IREF+3) 54 : XMAT(1,3)=OEIL(1)-XBAR(1) 55 : XMAT(2,3)=OEIL(2)-XBAR(2) 56 : XMAT(3,3)=OEIL(3)-XBAR(3) 57 : SMAT=SQRT(XMAT(1,3)**2+XMAT(2,3)**2+XMAT(3,3)**2) 57 : IF (SMAT.EQ.0.) CALL ERREUR(21) 58 : IF (IERR.NE.0) RETURN 59 : XMAT(1,3)=XMAT(1,3)/SMAT 60 : XMAT(2,3)=XMAT(2,3)/SMAT 61 : XMAT(3,3)=XMAT(3,3)/SMAT 62 : NBPTS=XCOOR(/1)/4+1 63 : SEGADJ MCOORD 64 : XCOOR((NBPTS-1)*4+1)=XMAT(1,3) 65 : XCOOR((NBPTS-1)*4+2)=XMAT(2,3) 66 : XCOOR((NBPTS-1)*4+3)=XMAT(3,3) 67 : XCOOR((NBPTS-1)*4+4)=1. 68 : ICPR(**)=0 69 : * AXE DES Z DONNE AXE DES Y 70 : ZCOMP=XMAT(3,3) 71 : XMAT(1,2)= (0.-XMAT(1,3)*ZCOMP) 72 : XMAT(2,2)= (0.-XMAT(2,3)*ZCOMP) 73 : XMAT(3,2)= (1.-XMAT(3,3)*ZCOMP) 74 : SMAT=SQRT(XMAT(1,2)**2+XMAT(2,2)**2+XMAT(3,2)**2) 75 : * SI PAS POSSIBLE PRENDRE AXE Y 76 : IF (SMAT.LE.0.1) THEN 77 : YCOMP=XMAT(2,3) 78 : XMAT(1,2)= (0.-XMAT(1,3)*YCOMP) 79 : XMAT(2,2)= (1.-XMAT(2,3)*YCOMP) 80 : XMAT(3,2)= (0.-XMAT(3,3)*YCOMP) 81 : SMAT=SQRT(XMAT(1,2)**2+XMAT(2,2)**2+XMAT(3,2)**2) 82 : ENDIF 83 : XMAT(1,2)=XMAT(1,2)/SMAT 84 : XMAT(2,2)=XMAT(2,2)/SMAT 85 : XMAT(3,2)=XMAT(3,2)/SMAT 86 : * TROISIEME VECTEUR 87 : XMAT(1,1)= (XMAT(2,2)*XMAT(3,3)-XMAT(3,2)*XMAT(2,3)) 88 : XMAT(2,1)= (XMAT(3,2)*XMAT(1,3)-XMAT(1,2)*XMAT(3,3)) 89 : XMAT(3,1)= (XMAT(1,2)*XMAT(2,3)-XMAT(2,2)*XMAT(1,3)) 90 : * PROJECTION 91 : DO 40 I=1,ICPR(/1) 92 : IP=ICPR(I) 93 : IF (IP.EQ.0) GOTO 40 94 : IREF=(IDIM+1)*(I-1) 95 : XINT(1)=XCOOR(IREF+1)-XBAR(1) 96 : XINT(2)=XCOOR(IREF+2)-XBAR(2) 97 : XINT(3)=XCOOR(IREF+3)-XBAR(3) 98 : XPROJ(1,IP)=XINT(1)*XMAT(1,1)+XINT(2)*XMAT(2,1)+XINT(3)*XMAT(3,1) 99 : XPROJ(2,IP)=XINT(1)*XMAT(1,2)+XINT(2)*XMAT(2,2)+XINT(3)*XMAT(3,2) 100 : XPROJ(3,IP)=XINT(1)*XMAT(1,3)+XINT(2)*XMAT(2,3)+XINT(3)*XMAT(3,3) 101 : XPROJ(3,IP)=-XPROJ(3,IP) 102 : 40 CONTINUE 103 : RETURN 104 : 100 CONTINUE 105 : IF (ICLE.NE.2) GOTO 200 106 : IF (IDIM.EQ.2) THEN 107 : DO 110 I=1,ICPR(/1) 108 : IP=ICPR(I) 109 : IF (IP.EQ.0) GOTO 110 110 : IREF=(IDIM+1)*(I-1) 111 : DO 120 J=1,2 112 : XCOOR(IREF+J)=XPROJ(J,IP) 113 : 120 CONTINUE 114 : 110 CONTINUE 115 : RETURN 116 : ENDIF 117 : * DEPROJECTION 118 : DO 140 I=1,ICPR(/1) 119 : IP=ICPR(I) 120 : IF (IP.EQ.0) GOTO 140 121 : IREF=(IDIM+1)*(I-1) 122 : YINT(1)=XPROJ(1,IP) 123 : YINT(2)=XPROJ(2,IP) 124 : YINT(3)=-XPROJ(3,IP) 125 : XINT(1)=YINT(1)*XMAT(1,1)+YINT(2)*XMAT(1,2)+YINT(3)*XMAT(1,3) 126 : XINT(2)=YINT(1)*XMAT(2,1)+YINT(2)*XMAT(2,2)+YINT(3)*XMAT(2,3) 127 : XINT(3)=YINT(1)*XMAT(3,1)+YINT(2)*XMAT(3,2)+YINT(3)*XMAT(3,3) 128 : XINT(1)=XINT(1)+XBAR(1) 129 : XINT(2)=XINT(2)+XBAR(2) 130 : XINT(3)=XINT(3)+XBAR(3) 131 : IF (ABS(XINT(1)-XCOOR(1+IREF)).GE.RPREC.OR. 132 : # ABS(XINT(2)-XCOOR(2+IREF)).GE.RPREC.OR. 133 : # ABS(XINT(3)-XCOOR(3+IREF)).GE.RPREC) THEN 134 : XCOOR(1+IREF)=XINT(1) 135 : XCOOR(2+IREF)=XINT(2) 136 : XCOOR(3+IREF)=XINT(3) 137 : IBOUJ(IP)=1 138 : ENDIF 139 : 140 CONTINUE 140 : RETURN 141 : 200 CONTINUE 142 : IF (ICLE.NE.3) GOTO 300 143 : IF (IDIM.EQ.2) THEN 144 : IPP=ICPR(IOEIL) 145 : IREF=(IDIM+1)*(IOEIL-1) 146 : DO 210 J=1,2 147 : XPROJ(J,IPP)=XCOOR(IREF+J) 148 : 210 CONTINUE 149 : RETURN 150 : ENDIF 151 : * REPROJECTION DU POINT IOEIL (NON CE N'EST PAS LE MEME) 152 : IP=ICPR(IOEIL) 153 : IF (IP.EQ.0) RETURN 154 : IREF=(IDIM+1)*(IOEIL-1) 155 : XINT(1)=XCOOR(IREF+1)-XBAR(1) 156 : XINT(2)=XCOOR(IREF+2)-XBAR(2) 157 : XINT(3)=XCOOR(IREF+3)-XBAR(3) 158 : XPROJ(1,IP)=XINT(1)*XMAT(1,1)+XINT(2)*XMAT(2,1)+XINT(3)*XMAT(3,1) 159 : XPROJ(2,IP)=XINT(1)*XMAT(1,2)+XINT(2)*XMAT(2,2)+XINT(3)*XMAT(3,2) 160 : XPROJ(3,IP)=XINT(1)*XMAT(1,3)+XINT(2)*XMAT(2,3)+XINT(3)*XMAT(3,3) 161 : XPROJ(3,IP)=-XPROJ(3,IP) 162 : RETURN 163 : 300 CONTINUE 164 : IF (IDIM.EQ.2) THEN 165 : IPP=ICPR(IOEIL) 166 : IREF=(IDIM+1)*(IOEIL-1) 167 : DO 310 J=1,2 168 : XCOOR(IREF+J)=XPROJ(J,IPP) 169 : 310 CONTINUE 170 : RETURN 171 : ENDIF 172 : * DEPROJECTION DU POINT IOEIL (NON CE N'EST PAS LE MEME) 173 : IP=ICPR(IOEIL) 174 : IF (IP.EQ.0) RETURN 175 : IREF=(IDIM+1)*(IOEIL-1) 176 : YINT(1)=XPROJ(1,IP) 177 : YINT(2)=XPROJ(2,IP) 178 : YINT(3)=-XPROJ(3,IP) 179 : XINT(1)=YINT(1)*XMAT(1,1)+YINT(2)*XMAT(1,2)+YINT(3)*XMAT(1,3) 180 : XINT(2)=YINT(1)*XMAT(2,1)+YINT(2)*XMAT(2,2)+YINT(3)*XMAT(2,3) 181 : XINT(3)=YINT(1)*XMAT(3,1)+YINT(2)*XMAT(3,2)+YINT(3)*XMAT(3,3) 182 : XINT(1)=XINT(1)+XBAR(1) 183 : XINT(2)=XINT(2)+XBAR(2) 184 : XINT(3)=XINT(3)+XBAR(3) 185 : IF (ABS(XINT(1)-XCOOR(1+IREF)).GE.RPREC.OR. 186 : # ABS(XINT(2)-XCOOR(2+IREF)).GE.RPREC.OR. 187 : # ABS(XINT(3)-XCOOR(3+IREF)).GE.RPREC) THEN 188 : XCOOR(1+IREF)=XINT(1) 189 : XCOOR(2+IREF)=XINT(2) 190 : XCOOR(3+IREF)=XINT(3) 191 : IBOUJ(IP)=1 192 : ENDIF 193 : END 194 :
© Cast3M 2003 - All rights reserved.
Disclaimer