1 : C KPROJF SOURCE CHAT 05/01/13 01:05:13 5004 2 : SUBROUTINE KPROJF(O1,A0,K1,K2 3 : * ,C,U2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP) 4 : IMPLICIT INTEGER(I-N) 5 : IMPLICIT REAL*8 (A-H,O-Z) 6 : C---------------------------------------------------------------------- 7 : C Calcul des facteurs de forme en 3D 8 : C Sp appele par FACGEN 9 : C PROJECTION DE LA FACE K2 PAR RAPPORT A UN POINT DE VUE PRIS 10 : C SUR LA FACE K1 (SP KPROJG) 11 : C ON DIVISE LA FACE K2 EN CAS D ERREUR ( SP KSUBDV) 12 : C 13 : C SP APPELE PAR KALFAC 14 : C 15 : C O1 : POINT DE VUE PRIS SUR K1 16 : C A0 : SOMMETS DU TRIANGLE DE LA FACE K2 17 : C K1 : INDICE DE LA PREMIERE FACE 18 : C K2 : INDICE DE LA DEUXIEME FACE 19 : C U2 : NORMALE A LA FACE K2 20 : C 21 : C NI LES POINTS NI LES ARETES N'ONT ETE PROJETES ANTERIEUREMENT 22 : C ON TRAITE LE NIVEAU 0 COMME LES SUIVANTS 23 : C 24 : C---------------------------------------------------------------------- 25 : C 26 : DIMENSION O1(3),U2(4),A0(3,3) 27 : C TABLEAUX DE TRAVAIL 28 : DIMENSION AA0(3,3,4) 29 : DIMENSION A1(3,3),AA1(3,3,4) 30 : DIMENSION A2(3,3),AA2(3,3,4) 31 : DIMENSION A3(3,3),AA3(3,3,4) 32 : DIMENSION A4(3,3),AA4(3,3,4) 33 : DIMENSION A5(3,3),AA5(3,3,4) 34 : DIMENSION A6(3,3),AA6(3,3,4) 35 : DIMENSION BBB(3,3,1) 36 : C 37 : -INC TFFOR3D 38 : C 39 : C-------------------------------------------------------------- 40 : SEGMENT SPROGP 41 : INTEGER KF(NPT),ICOO(2,NPT) 42 : REAL*8 XR(3,NPT) 43 : ENDSEGMENT 44 : C-------------------------------------------------------------- 45 : SEGMENT SKCEL 46 : INTEGER KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC) 47 : REAL*8 RMAX 48 : ENDSEGMENT 49 : C 50 : C-------------------------------------------------------------------- 51 : C 52 : C NIVEAU 0 53 : C -------- 54 : C DEFINITION DE BBB 55 : C 56 : DO 11 K=1,3 57 : DO 12 I=1,3 58 : BBB(K,I,1) = A0(K,I) 59 : 12 CONTINUE 60 : 11 CONTINUE 61 : 62 : NSUB = 1 63 : KSUB = 1 63 : CALL KSUBCR(O1,KSUB,NSUB,BBB,SHC3D,SPROGP,SPROJA) 64 : 65 : NNF1 = KF(1) 66 : NNF2 = KF(2) 67 : NNF3 = KF(3) 67 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 68 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 69 : 70 : IF (KERR.EQ.0) RETURN 71 : C WRITE(6,*) ' NIV 0 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB 72 : 73 : 74 : C NIVEAU 1 75 : C -------- 75 : CALL KSUBDV(A0,AA0,NSUB) 76 : 77 : DO 100 KSUB = 1,NSUB 78 : 78 : CALL KSUBCR(O1,KSUB,NSUB,AA0,SHC3D,SPROGP,SPROJA) 79 : 80 : NNF1 = KF(1) 81 : NNF2 = KF(2) 82 : NNF3 = KF(3) 82 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 83 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 84 : 85 : IF (KERR.EQ.0) GOTO 100 86 : C WRITE(6,*) ' NIV 1 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB 87 : 88 : C 89 : C NIVEAU 2 90 : C -------- 91 : C 92 : C DEFIINITION DE A1 93 : C 94 : DO 110 K=1,3 95 : DO 111 I=1,3 96 : A1(K,I) = AA0(K,I,KSUB) 97 : 111 CONTINUE 98 : 110 CONTINUE 99 : C 99 : CALL KSUBDV(A1,AA1,NSUB2) 100 : 101 : DO 200 KSUB2 = 1,NSUB2 102 : 102 : CALL KSUBCR(O1,KSUB2,NSUB2,AA1,SHC3D,SPROGP,SPROJA) 103 : 104 : NNF1 = KF(1) 105 : NNF2 = KF(2) 106 : NNF3 = KF(3) 106 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 107 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 108 : 109 : IF (KERR.EQ.0) GOTO 200 110 : C WRITE(6,*) ' NIV 2 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB2 111 : 112 : C NIVEAU 3 113 : C -------- 114 : C 115 : C DEFIINITION DE A2 116 : C 117 : DO 210 K=1,3 118 : DO 211 I=1,3 119 : A2(K,I) = AA1(K,I,KSUB2) 120 : 211 CONTINUE 121 : 210 CONTINUE 122 : C 122 : CALL KSUBDV(A2,AA2,NSUB3) 123 : 124 : DO 300 KSUB3 = 1,NSUB3 125 : 125 : CALL KSUBCR(O1,KSUB3,NSUB3,AA2,SHC3D,SPROGP,SPROJA) 126 : 127 : NNF1 = KF(1) 128 : NNF2 = KF(2) 129 : NNF3 = KF(3) 129 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 130 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 131 : 132 : IF (KERR.EQ.0) GOTO 300 133 : C WRITE(6,*) ' NIV 3 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB3 134 : 135 : C NIVEAU 4 136 : C -------- 137 : C 138 : C DEFIINITION DE A3 139 : C 140 : DO 310 K=1,3 141 : DO 311 I=1,3 142 : A3(K,I) = AA2(K,I,KSUB3) 143 : 311 CONTINUE 144 : 310 CONTINUE 145 : C 145 : CALL KSUBDV(A3,AA3,NSUB4) 146 : 147 : DO 400 KSUB4 = 1,NSUB4 148 : 148 : CALL KSUBCR(O1,KSUB4,NSUB4,AA3,SHC3D,SPROGP,SPROJA) 149 : 150 : NNF1 = KF(1) 151 : NNF2 = KF(2) 152 : NNF3 = KF(3) 152 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 153 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 154 : 155 : IF (KERR.EQ.0) GOTO 400 156 : C WRITE(6,*) ' NIV 4 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB4 157 : 158 : C** 159 : C NIVEAU 5 160 : C -------- 161 : C 162 : C DEFIINITION DE A4 163 : C 164 : DO 410 K=1,3 165 : DO 411 I=1,3 166 : A4(K,I) = AA3(K,I,KSUB4) 167 : 411 CONTINUE 168 : 410 CONTINUE 169 : C 169 : CALL KSUBDV(A4,AA4,NSUB5) 170 : 171 : DO 500 KSUB5 = 1,NSUB5 172 : 172 : CALL KSUBCR(O1,KSUB5,NSUB5,AA4,SHC3D,SPROGP,SPROJA) 173 : 174 : NNF1 = KF(1) 175 : NNF2 = KF(2) 176 : NNF3 = KF(3) 176 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 177 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 178 : 179 : IF (KERR.EQ.0) GOTO 500 180 : C WRITE(6,*) ' NIV 5 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5 181 : 182 : C NIVEAU 6 183 : C -------- 184 : C 185 : C DEFIINITION DE A5 186 : C 187 : DO 510 K=1,3 188 : DO 511 I=1,3 189 : A5(K,I) = AA4(K,I,KSUB4) 190 : 511 CONTINUE 191 : 510 CONTINUE 192 : C 192 : CALL KSUBDV(A5,AA5,NSUB6) 193 : 194 : DO 600 KSUB6 = 1,NSUB6 195 : 195 : CALL KSUBCR(O1,KSUB6,NSUB6,AA5,SHC3D,SPROGP,SPROJA) 196 : 197 : NNF1 = KF(1) 198 : NNF2 = KF(2) 199 : NNF3 = KF(3) 199 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 200 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 201 : 202 : IF (KERR.EQ.0) GOTO 600 203 : C WRITE(6,*) ' NIV 6 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5 204 : 205 : 206 : C NIVEAU 7 207 : C -------- 208 : C 209 : C DEFIINITION DE A6 210 : C 211 : DO 610 K=1,3 212 : DO 611 I=1,3 213 : A6(K,I) = AA5(K,I,KSUB4) 214 : 611 CONTINUE 215 : 610 CONTINUE 216 : C 216 : CALL KSUBDV(A6,AA6,NSUB7) 217 : 218 : DO 700 KSUB7 = 1,NSUB7 219 : 219 : CALL KSUBCR(O1,KSUB7,NSUB7,AA6,SHC3D,SPROGP,SPROJA) 220 : 221 : NNF1 = KF(1) 222 : NNF2 = KF(2) 223 : NNF3 = KF(3) 223 : CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3 224 : * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR) 225 : 226 : IF (KERR.EQ.0) GOTO 700 227 : C WRITE(6,*) ' NIV 7 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5 228 : WRITE(6,900) K2,K1,KERR 229 : 900 FORMAT(1X,' LA FACE ',I4,' EST GRANDE OU TRES PROCHE DE LA FACE ' 230 : $,I4,' NIVEAU D ERREUR ',I2) 231 : 232 : C** 233 : 700 CONTINUE 234 : 600 CONTINUE 235 : 500 CONTINUE 236 : C** 237 : 400 CONTINUE 238 : 300 CONTINUE 239 : 200 CONTINUE 240 : 100 CONTINUE 241 : RETURN 242 : END 243 : 244 :
© Cast3M 2003 - All rights reserved.
Disclaimer