1 : C RDEPLA SOURCE AM 08/02/14 21:28:09 6050 2 : SUBROUTINE RDEPLA(MCHPOI) 3 : C===================================================================== 4 : C OPERATEUR POUR CHANGER DE REPERE SUR UN CHAMP DE DEPLACEMENTS 5 : C (OU TOUT CHAMP PAR POINTS) 6 : C 7 : C MCHPO1 = RDEP MCHPOI IVEC1 (IVEC2) 8 : C Entrées : MCHPOI : MCHPOI Champ de déplacements 9 : C VEC1 : POINT Premier vecteur du repère 10 : C VEC2 : POINT Deuxième vecteur du repère 11 : C Sortie : MCHPO1 : MCHPOI Champ de déplacements 12 : C 13 : C===================================================================== 14 : C 15 : IMPLICIT INTEGER(I-N) 16 : IMPLICIT REAL*8(A-H,O-Z) 17 : -INC CCOPTIO 18 : -INC CCHAMP 19 : -INC SMCHPOI 20 : -INC SMCOORD 21 : C 22 : C Déclarations 23 : C 24 : *** Vecteurs du repère 25 : REAL*8 XU(3), XV(3), XW(3) 26 : *** Tableau de pointeurs sur des segments 27 : INTEGER IDEP(6,2) 28 : *** Tableau des déplacements d'un noeud 29 : REAL*8 XDEP(3), XROT(3) 30 : *** Matrice de changement de repère 31 : REAL*8 XMATC(3,3) 32 : C 33 : C Corps 34 : C 35 : IRET=0 36 : C 37 : C Lecture du champ de déplacements 38 : C 38 : * CALL LIROBJ('CHPOINT', MCHPOI, 1, IRET) 39 : * IF (IERR.NE.0) RETURN 40 : C 41 : C Lecture du ou des vecteurs du repère 42 : C 42 : CALL LIROBJ('POINT', IVEC1, 1, IRET) 43 : IF (IERR.NE.0) RETURN 44 : IREU = (IDIM + 1)*(IVEC1 - 1) 45 : XNORU = 0. 46 : DO 1 IC = 1, IDIM 47 : XU(IC) = XCOOR(IREU + IC) 48 : XNORU = XNORU + XU(IC)*XU(IC) 49 : 1 CONTINUE 50 : XNORU = SQRT(XNORU) 51 : DO 10 IC = 1, IDIM 52 : 10 XU(IC) = XU(IC)/XNORU 53 : IF (IDIM .EQ. 3) THEN 53 : CALL LIROBJ('POINT', IVEC2, 1, IRET) 54 : IF (IERR.NE.0) RETURN 55 : IREV = (IDIM + 1)*(IVEC2 - 1) 56 : XNORV = 0. 57 : DO 2 IC = 1, IDIM 58 : XV(IC) = XCOOR(IREV + IC) 59 : XNORV = XNORV + XV(IC)*XV(IC) 60 : 2 CONTINUE 61 : XNORV = SQRT(XNORV) 62 : DO 11 IC = 1, IDIM 63 : 11 XV(IC) = XV(IC)/XNORV 64 : XW(1) = XU(2)*XV(3) - XU(3)*XV(2) 65 : XW(2) = XU(3)*XV(1) - XU(1)*XV(3) 66 : XW(3) = XU(1)*XV(2) - XU(2)*XV(1) 67 : XNORW = 0. 68 : DO 8 IC = 1, IDIM 69 : XNORW = XNORW + XW(IC)*XW(IC) 70 : 8 CONTINUE 71 : XNORW = SQRT(XNORW) 72 : DO 15 IC = 1, IDIM 73 : 15 XW(IC) = XW(IC)/XNORW 74 : XV(1) = XW(2)*XU(3) - XW(3)*XU(2) 75 : XV(2) = XW(3)*XU(1) - XW(1)*XU(3) 76 : XV(3) = XW(1)*XU(2) - XW(2)*XU(1) 77 : DO 12 IC = 1, IDIM 78 : XMATC(1, IC) = XU(IC) 79 : XMATC(2, IC) = XV(IC) 80 : XMATC(3, IC) = XW(IC) 81 : 12 CONTINUE 82 : ELSE 83 : XV(1) = -XU(2) 84 : XV(2) = XU(1) 85 : DO 13 IC = 1, IDIM 86 : XMATC(1, IC) = XU(IC) 87 : XMATC(2, IC) = XV(IC) 88 : 13 CONTINUE 89 : ENDIF 90 : * WRITE (*,*) 'Matrice de changement de repère :' 91 : * DO 14 IL = 1, IDIM 92 : * IF (IDIM .EQ. 3) THEN 93 : * WRITE (*,*) ' ',XMATC(IL,1),' ',XMATC(IL,2), 94 : * # ' ',XMATC(IL,3) 95 : * ELSE 96 : * WRITE (*,*) ' ',XMATC(IL,1),' ',XMATC(IL,2) 97 : * ENDIF 98 : * 14 CONTINUE 99 : DO 30 II = 1, 6 100 : DO 30 IJ = 1, 2 101 : 30 IDEP(II, IJ) = 0 102 : SEGINI, MCHPO1 = MCHPOI 103 : SEGACT, MCHPOI 104 : DO 80 IMS = 1, MCHPOI.IPCHP(/1) 105 : MSOUPO = MCHPOI.IPCHP(IMS) 106 : SEGACT, MSOUPO 107 : SEGINI, MSOUP1 = MSOUPO 108 : MPOVAL = MSOUPO.IPOVAL 109 : SEGINI, MPOVA1 = MPOVAL 110 : MSOUP1.IPOVAL = MPOVA1 111 : MCHPO1.IPCHP(IMS) = MSOUP1 112 : SEGDES, MSOUPO 113 : SEGDES, MSOUP1 114 : SEGDES, MPOVA1 115 : 80 CONTINUE 116 : IF (IFOMOD .EQ. 0 .OR. IFOMOD .EQ. 1) GOTO 100 117 : SEGACT, MCHPOI 118 : * WRITE (*,*) 'Nombre de pointeurs sur MSOUPO',MCHPO1.IPCHP(/1) 119 : DO 3 IMS = 1, MCHPO1.IPCHP(/1) 120 : * WRITE (*,*) ' MSOUPO # ', IMS 121 : MSOUPO = MCHPOI.IPCHP(IMS) 122 : SEGACT, MSOUPO 123 : * WRITE(*,*) ' ', MSOUPO.NOHARM(/1), ' composantes' 124 : DO 70 II = 1, 6 125 : DO 70 IJ = 1, 2 126 : 70 IDEP(II, IJ) = 0 127 : DO 4 IC = 1, MSOUPO.NOHARM(/1) 128 : * WRITE (*,*) ' :',MSOUPO.NOCOMP(IC) 129 : ***-----------Pour UX 129 : CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(1), 4, IRET) 130 : IF (IRET .EQ. 1) THEN 131 : IDEP(1,1) = IMS 132 : IDEP(1,2) = IC 133 : IRET = 0 134 : * WRITE (*,*) NOMDD(1),'détecté en ',IDEP(1,2),' de ',IDEP(1,1) 135 : ELSE 136 : ***-----------Pour UY 136 : CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(2), 4, IRET) 137 : IF (IRET .EQ. 1) THEN 138 : IDEP(2,1) = IMS 139 : IDEP(2,2) = IC 140 : IRET = 0 141 : * WRITE (*,*) NOMDD(2),'détecté en ',IDEP(2,2),' de ',IDEP(2,1) 142 : ELSE 143 : ***-----------Pour UZ 143 : CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(3), 4, IRET) 144 : IF (IRET .EQ. 1) THEN 145 : IDEP(3,1) = IMS 146 : IDEP(3,2) = IC 147 : IRET = 0 148 : * WRITE (*,*) NOMDD(3),'détecté en ',IDEP(3,2),' de ',IDEP(3,1) 149 : ELSE 150 : ***-----------Pour RX 150 : CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(4), 4, IRET) 151 : IF (IRET .EQ. 1) THEN 152 : IDEP(4,1) = IMS 153 : IDEP(4,2) = IC 154 : IRET = 0 155 : * WRITE (*,*) NOMDD(4),'détecté en ',IDEP(4,2),' de ',IDEP(4,1) 156 : ELSE 157 : ***-----------Pour RY 157 : CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(5), 4, IRET) 158 : IF (IRET .EQ. 1) THEN 159 : IDEP(5,1) = IMS 160 : IDEP(5,2) = IC 161 : IRET = 0 162 : * WRITE (*,*) NOMDD(5),'détecté en ',IDEP(5,2),' de ',IDEP(5,1) 163 : ELSE 164 : ***-----------Pour RZ 164 : CALL STRNCP(MSOUPO.NOCOMP(IC), NOMDD(6), 4, IRET) 165 : IF (IRET .EQ. 1) THEN 166 : IDEP(6,1) = IMS 167 : IDEP(6,2) = IC 168 : IRET = 0 169 : * WRITE (*,*) NOMDD(6),'détecté en ',IDEP(6,2),' de ',IDEP(6,1) 170 : ENDIF 171 : ENDIF 172 : ENDIF 173 : ENDIF 174 : ENDIF 175 : ENDIF 176 : 4 CONTINUE 177 : MPOVAL = MSOUPO.IPOVAL 178 : SEGACT, MPOVAL 179 : INP = MPOVAL.VPOCHA(/1) 180 : ***----Pour chaque composante à transformer 181 : MSOUP1 = MCHPO1.IPCHP(IMS) 182 : SEGACT, MSOUP1 183 : MPOVA1 = MSOUP1.IPOVAL 184 : SEGACT, MPOVA1*MOD 185 : * DO 400 IC = 1, 6 186 : * WRITE (*,*) ' ' 187 : * WRITE (*,*) ' IDEP(',IC,',1) = ', IDEP(IC,1) 188 : * WRITE (*,*) ' IDEP(',IC,',2) = ', IDEP(IC,2) 189 : * 400 CONTINUE 190 : DO 50 IN = 1, INP 191 : DO 40 IC = 1, 3 192 : IF (IDEP(IC,1) .NE. 0) THEN 193 : XDEP(IC) = MPOVAL.VPOCHA(IN,IDEP(IC,2)) 194 : * WRITE (*,*) 'XDEP(',IC,') = ', XDEP(IC) 195 : ENDIF 196 : ICL = IC + 3 197 : IF (IDEP(ICL,1) .NE. 0) THEN 198 : XROT(IC) = MPOVAL.VPOCHA(IN,IDEP(ICL,2)) 199 : * WRITE (*,*) 'XROT(',IC,') = ', XROT(IC) 200 : ENDIF 201 : 40 CONTINUE 202 : DO 41 IC = 1, 3 203 : IF (IDEP(IC,1) .NE. 0) THEN 204 : MPOVA1.VPOCHA(IN,IDEP(IC,2)) = 0. 205 : DO 42 IJ = 1, 3 206 : MPOVA1.VPOCHA(IN,IDEP(IC,2)) = 207 : # MPOVA1.VPOCHA(IN,IDEP(IC,2)) + XMATC(IC,IJ)*XDEP(IJ) 208 : 42 CONTINUE 209 : ENDIF 210 : ICL = IC + 3 211 : IF (IDEP(ICL,1) .NE. 0) THEN 212 : MPOVA1.VPOCHA(IN,IDEP(ICL,2)) = 0. 213 : DO 43 IJ = 1, 3 214 : MPOVA1.VPOCHA(IN,IDEP(ICL,2)) = 215 : # MPOVA1.VPOCHA(IN,IDEP(ICL,2)) + XMATC(IC,IJ)*XROT(IJ) 216 : 43 CONTINUE 217 : ENDIF 218 : 41 CONTINUE 219 : 50 CONTINUE 220 : SEGDES, MPOVA1 221 : SEGDES, MSOUP1 222 : SEGDES, MPOVAL 223 : SEGDES, MSOUPO 224 : 3 CONTINUE 225 : 226 : SEGDES, MCHPOI 227 : SEGDES, MCHPO1 228 : C 229 : C Ecriture du champ de déplacements 230 : C 231 : 100 CONTINUE 231 : CALL ECROBJ('CHPOINT', MCHPO1) 232 : RETURN 233 : END 234 : 235 : 236 : 237 : 238 : 239 : 240 : 241 :
© Cast3M 2003 - All rights reserved.
Disclaimer