1 : C TRIPLE SOURCE CHAT 05/01/13 03:47:39 5004 2 : SUBROUTINE TRIPLE(ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 3 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,YUNG,XNU,SIGEL,DSIGP,DLAMBD, 4 : .XLAMBD,ICOUP,ICAS,ICRIT1,ICRIT2,ICRIME,ICRIMT,SIGMA,DSIGMA,XX, 5 : .PREC,RFSG,RFEP,RFPR,KERRE) 6 : C 7 : IMPLICIT INTEGER(I-N) 8 : IMPLICIT REAL*8(A-H,O-Z) 9 : -INC CCOPTIO 10 : C 11 : DIMENSION SIGEL(*),DSIGP(*),DLAMBD(*),XLAMBD(*) 12 : DIMENSION SIGMA(*),DSIGMA(*) 13 : DIMENSION DF1(6),DF2(6),DF3(6),SIGMAT(6),SIG(6) 14 : DIMENSION A(3,3),C(3),DDLAM(3) 15 : C 16 : C IC1 INDICE DU CRITERE 1 17 : C IC2 INDICE DU CRITERE 2 18 : C IC3 INDICE DU CRITERE 3 19 : C DLAMBD(IC1) INCREMENT DLMBDA POUR LE CRITERE 1 20 : C DLAMBD(IC2) INCREMENT DLMBDA POUR LE CRITERE 2 21 : C DLAMBD(IC3) INCREMENT DLMBDA POUR LE CRITERE 3 22 : C DDLAM1 CORRECTION A DLAMBD(IC1) AU COURS DES ITERATIONS INTERNES 23 : C DDLAM2 CORRECTION A DLAMBD(IC2) AU COURS DES ITERATIONS INTERNES 24 : C DDLAM3 CORRECTION A DLAMBD(IC3) AU COURS DES ITERATIONS INTERNES 25 : C SIG ETAT DE CONTRAINTES FINAL PROJETTE 26 : C SIGEL ETAT DE CONTRAINTES INITIAL 27 : C DSIGP INCREMENT DE CONTRAINTES A ECOULER 28 : C MAXITE NOMBRE MAXIMAL D'ITERATIONS INTERNES 29 : C PREC PRECISION POUR LA CONVERGENCE DES ITERATIONS INTERNES 30 : C 31 : DO 1 I=1,6 32 : SIGMAT(I)=SIGEL(I)+DSIGP(I) 33 : SIGMA(I)=SIGEL(I) 34 : 1 CONTINUE 35 : C 36 : IF(IIMPI.EQ.9) THEN 37 : WRITE(IOIMP,3001) (SIGEL(I),I=1,6) 38 : WRITE(IOIMP,3002) (DSIGP(I),I=1,6) 39 : WRITE(IOIMP,3003) (SIGMAT(I),I=1,6) 40 : ENDIF 41 : C 42 : DATA MAXITE/30/ 43 : IC1=1 44 : IC2=2 45 : IC3=3 46 : DO 2 I=1,3 47 : DDLAM(I)=0.D0 48 : 2 CONTINUE 49 : TRSIGE=SIGEL(1)+SIGEL(2)+SIGEL(3) 50 : SIGEQ2=AVM(SIGEL,SIGEL) 51 : SIGEQ=SQRT(SIGEQ2) 52 : C 53 : SU=1.5*YUNG/(1.D0+XNU) 54 : DU=YUNG/(1.D0-2.D0*XNU) 55 : C 56 : C CALCUL DU: A11, A22, A33, A12, A23, A31 57 : C 58 : A(1,1)=PENTE3+DU/3.D0 59 : A(2,2)=SU+ALFADV*ALFADV*DU*3.D0 60 : A(3,3)=PENTE1+SU 61 : A(1,2)=-ALFADV*DU 62 : A(2,1)=A(1,2) 63 : A(2,3)=SU 64 : A(3,2)=SU 65 : A(3,1)=0.D0 66 : A(1,3)=0.D0 67 : C 68 : C CALCUL DU: C(1), C(2), C(3) 69 : C 69 : CALL KRITER(IC1,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 70 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,DDLAM(1),SIGEL,FSG,C(1),KERRE) 70 : CALL KRITER(IC2,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 71 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,DDLAM(2),SIGEL,FSG,C(2),KERRE) 71 : CALL KRITER(IC3,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 72 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,DDLAM(3),SIGEL,FSG,C(3),KERRE) 73 : C 74 : IF(IIMPI.EQ.9) WRITE(IOIMP,3004) (C(I),I=1,3) 75 : C 76 : TRDSIG=DSIGP(1)+DSIGP(2)+DSIGP(3) 77 : FF=SIGEL(1)*DSIGP(1)+SIGEL(2)*DSIGP(2)+SIGEL(3)*DSIGP(3) 78 : ZZ=2.D0*(SIGEL(4)*DSIGP(4)+SIGEL(5)*DSIGP(5)+SIGEL(6)*DSIGP(6)) 79 : TRSIDS=FF+ZZ-TRSIGE*TRDSIG/3.D0 80 : C(1)=C(1)-TRDSIG/3.D0 81 : C(2)=C(2)+ALFADV*TRDSIG+1.5D0*TRSIDS/SIGEQ 82 : C(3)=C(3)+1.5D0*TRSIDS/SIGEQ 83 : C 84 : C CALCUL DU: DDLAM(1),DDLAM(2),DDLAM(3) 85 : C 85 : CALL RESNEQ(A,C,DDLAM,3,KERRE) 86 : C 87 : IF(IIMPI.EQ.9) THEN 88 : WRITE(IOIMP,3004) (C(I),I=1,3) 89 : WRITE(IOIMP,3005) (DDLAM(I),I=1,3) 90 : ENDIF 91 : C 92 : C INITIALISATIONS 93 : C 94 : ZR=0.D0 95 : ITER=0 96 : ICOUP=0 97 : ICRIT1=0 98 : ICRIT2=0 99 : ICRIME=0 100 : ICRIMT=0 101 : IBOU=6 102 : VMELA0=VMELAS 103 : DPEL20=DPELA2 104 : POREL0=PORELA 105 : DO 3 I=1,IBOU 106 : 3 SIG(I)=SIGEL(I) 107 : DLAM01=DLAMBD(IC1) 108 : DLAM02=DLAMBD(IC2) 109 : DLAM03=DLAMBD(IC3) 110 : DLAMBD(IC1)=DDLAM(1) 111 : DLAMBD(IC2)=DDLAM(2) 112 : DLAMBD(IC3)=DDLAM(3) 113 : C 114 : IF(ABS(DLAMBD(IC1)).LE.RFEP) DLAMBD(IC1)=0.D0 115 : IF(ABS(DLAMBD(IC2)).LE.RFEP) DLAMBD(IC2)=0.D0 116 : IF(ABS(DLAMBD(IC3)).LE.RFEP) DLAMBD(IC3)=0.D0 117 : C 118 : IF(DLAMBD(IC1).GT.0.D0.AND.DLAMBD(IC2).GT.0.D0. 119 : . AND.DLAMBD(IC3).GT.0.D0) GO TO 9 120 : IF(DLAMBD(IC1).GT.0.D0.OR.DLAMBD(IC2).GT.0.D0. 121 : . OR.DLAMBD(IC3).GT.0.D0) GO TO 309 122 : IF(DLAMBD(IC1).EQ.0.D0.AND.DLAMBD(IC2).EQ.0.D0. 123 : . AND.DLAMBD(IC3).EQ.0.D0) GO TO 313 124 : WRITE(IOIMP,901) IC1,DLAMBD(IC1),IC2,DLAMBD(IC2),IC3,DLAMBD(IC3) 125 : KERRE=640 126 : RETURN 127 : C 128 : 9 CONTINUE 129 : C 130 : C LE CALCUL DE DLAMBD PREMIERE ESTIMATION 131 : C 132 : ITER=1 132 : CALL KRITER(IC1,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 133 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,ZR,SIGMAT,FSG,C(1),KERRE) 133 : CALL KRITER(IC2,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 134 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,ZR,SIGMAT,FSG,C(2),KERRE) 134 : CALL KRITER(IC3,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 135 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,ZR,SIGMAT,FSG,C(3),KERRE) 136 : C 137 : C CALCUL DU: A11, A22, A33, A12, A23, A31 138 : C 139 : A(1,1)=PENTE3+DU/3.D0 140 : A(2,2)=SU+ALFADV*ALFADV*DU*3.D0 141 : A(3,3)=PENTE1+SU 142 : A(1,2)=-ALFADV*DU 143 : A(2,1)=A(1,2) 144 : A(2,3)=SU 145 : A(3,2)=SU 146 : A(3,1)=0.D0 147 : A(1,3)=0.D0 148 : C 148 : CALL RESNEQ(A,C,DDLAM,3,KERRE) 149 : C 150 : IF(IIMPI.EQ.9) THEN 151 : WRITE(IOIMP,3004) (C(I),I=1,3) 152 : WRITE(IOIMP,3005) (DDLAM(I),I=1,3) 153 : ENDIF 154 : C 155 : DLAMBD(IC1)=DDLAM(1) 156 : DLAMBD(IC2)=DDLAM(2) 157 : DLAMBD(IC3)=DDLAM(3) 158 : C 158 : CALL DDFDS(IC1,ALFADV,ALFAD1,ALFAD2,YUNG,XNU,SIGMAT,SIG, 159 : .DF1,KERRE) 159 : CALL DDFDS(IC2,ALFADV,ALFAD1,ALFAD2,YUNG,XNU,SIGMAT,SIG, 160 : .DF2,KERRE) 160 : CALL DDFDS(IC3,ALFADV,ALFAD1,ALFAD2,YUNG,XNU,SIGMAT,SIG, 161 : .DF3,KERRE) 162 : DO 4 I=1,IBOU 163 : SIG(I)=SIG(I)-DF1(I)*DDLAM(1)-DF2(I)*DDLAM(2)-DF3(I)*DDLAM(3) 164 : SIG(I)=SIG(I)+DSIGP(I) 165 : 4 CONTINUE 166 : C 167 : IF(IIMPI.EQ.9) THEN 168 : WRITE(IOIMP,3006) (DF1(I),I=1,6) 169 : WRITE(IOIMP,3007) (DF2(I),I=1,6) 170 : WRITE(IOIMP,3008) (DF3(I),I=1,6) 171 : WRITE(IOIMP,3009) (SIG(I),I=1,6) 172 : ENDIF 173 : C 174 : C ITERATIONS INTERNES 175 : C 176 : 333 ITER=ITER+1 176 : CALL KRITER(IC1,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 177 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,DDLAM(1),SIG,FSG,C(1),KERRE) 177 : CALL KRITER(IC2,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 178 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,DDLAM(2),SIG,FSG,C(2),KERRE) 178 : CALL KRITER(IC3,ALFADV,ALFAD1,ALFAD2,VMELAS,DPELAS,DPELA1, 179 : .DPELA2,PORELA,PENTE1,PENTE2,PENTE3,DDLAM(3),SIG,FSG,C(3),KERRE) 180 : C 181 : C CALCUL DU: A11, A22, A33, A12, A23, A31 182 : C 183 : A(1,1)=PENTE3+DU/3.D0 184 : A(2,2)=SU+ALFADV*ALFADV*DU*3.D0 185 : A(3,3)=PENTE1+SU 186 : A(1,2)=-ALFADV*DU 187 : A(2,1)=A(1,2) 188 : A(2,3)=SU 189 : A(3,2)=SU 190 : A(3,1)=0.D0 191 : A(1,3)=0.D0 192 : C 192 : CALL RESNEQ(A,C,DDLAM,3,KERRE) 193 : C 194 : IF(IIMPI.EQ.9) THEN 195 : WRITE(IOIMP,3004) (C(I),I=1,3) 196 : WRITE(IOIMP,3005) (DDLAM(I),I=1,3) 197 : ENDIF 198 : C 198 : CALL DDFDS(IC1,ALFADV,ALFAD1,ALFAD2,YUNG,XNU,SIG,SIG, 199 : .DF1,KERRE) 199 : CALL DDFDS(IC2,ALFADV,ALFAD1,ALFAD2,YUNG,XNU,SIG,SIG, 200 : .DF2,KERRE) 200 : CALL DDFDS(IC3,ALFADV,ALFAD1,ALFAD2,YUNG,XNU,SIG,SIG, 201 : .DF3,KERRE) 202 : DO 5 I=1,IBOU 203 : SIG(I)=SIG(I)-DF1(I)*DDLAM(1)-DF2(I)*DDLAM(2)-DF3(I)*DDLAM(3) 204 : 5 CONTINUE 205 : C 206 : IF(IIMPI.EQ.9) THEN 207 : WRITE(IOIMP,3006) (DF1(I),I=1,6) 208 : WRITE(IOIMP,3007) (DF2(I),I=1,6) 209 : WRITE(IOIMP,3008) (DF3(I),I=1,6) 210 : WRITE(IOIMP,3009) (SIG(I),I=1,6) 211 : ENDIF 212 : C 213 : DLAMBD(IC1)=DLAMBD(IC1)+DDLAM(1) 214 : DLAMBD(IC2)=DLAMBD(IC2)+DDLAM(2) 215 : DLAMBD(IC3)=DLAMBD(IC3)+DDLAM(3) 216 : C 217 : IF(ABS(DLAMBD(IC1)).LE.RFEP) DLAMBD(IC1)=0.D0 218 : IF(ABS(DLAMBD(IC2)).LE.RFEP) DLAMBD(IC2)=0.D0 219 : IF(ABS(DLAMBD(IC3)).LE.RFEP) DLAMBD(IC3)=0.D0 220 : C 221 : IF(DLAMBD(IC1).GT.0.D0.AND.DLAMBD(IC2).GT.0.D0. 222 : . AND.DLAMBD(IC3).GT.0.D0) GO TO 310 223 : IF(DLAMBD(IC1).GT.0.D0.OR.DLAMBD(IC2).GT.0.D0. 224 : . OR.DLAMBD(IC3).GT.0.D0) GO TO 309 225 : IF(DLAMBD(IC1).EQ.0.D0.AND.DLAMBD(IC2).EQ.0.D0. 226 : . AND.DLAMBD(IC3).EQ.0.D0) GO TO 313 227 : WRITE(IOIMP,901) IC1,DLAMBD(IC1),IC2,DLAMBD(IC2),IC3,DLAMBD(IC3) 228 : KERRE=640 229 : RETURN 230 : C 231 : C TESTS 232 : C 233 : 310 TEST1=ABS(DDLAM(1))/DLAMBD(IC1) 234 : TEST2=ABS(DDLAM(2))/DLAMBD(IC2) 235 : TEST3=ABS(DDLAM(3))/DLAMBD(IC3) 236 : IF(TEST1.LT.PREC.AND.TEST2.LT.PREC.AND.TEST3.LT.PREC) GO TO 311 237 : IF(ITER.LE.MAXITE) GO TO 333 238 : WRITE(IOIMP,900) IC1,TEST1,IC2,TEST2,IC3,TEST3 239 : KERRE=640 240 : RETURN 241 : C 242 : C IL Y A TRIPLAGE 243 : C 244 : 311 ICOUP=3 245 : ICRIT1=IC1 246 : ICRIT2=IC2 247 : ICRIT3=IC3 248 : C 248 : CALL KRITER(IC1,ALFADV,ALFAD1,ALFAD2,VMELA0,DPELAS,DPELA1, 249 : .DPEL20,POREL0,PENTE1,PENTE2,PENTE3,DLAMBD(IC1),SIG,FSG,C(1),KERRE) 249 : CALL KRITER(IC2,ALFADV,ALFAD1,ALFAD2,VMELA0,DPELAS,DPELA1, 250 : .DPEL20,POREL0,PENTE1,PENTE2,PENTE3,DLAMBD(IC2),SIG,FSG,C(2),KERRE) 250 : CALL KRITER(IC3,ALFADV,ALFAD1,ALFAD2,VMELA0,DPELAS,DPELA1, 251 : .DPEL20,POREL0,PENTE1,PENTE2,PENTE3,DLAMBD(IC3),SIG,FSG,C(3),KERRE) 252 : C 253 : VMELAS=VMELA0 254 : DPELA2=DPEL20 255 : PORELA=POREL0 256 : C 257 : DLAMBD(IC1)=DLAMBD(IC1)+DLAM01 258 : DLAMBD(IC2)=DLAMBD(IC2)+DLAM02 259 : DLAMBD(IC3)=DLAMBD(IC3)+DLAM03 260 : DO 7 I=1,5 261 : XLAMBD(I)=XLAMBD(I)+DLAMBD(I) 262 : DLAMBD(I)=0.D0 263 : 7 CONTINUE 264 : DO 8 I=1,IBOU 265 : SIGEL(I)=SIG(I) 266 : DSIGP(I)=0.D0 267 : DSIGMA(I)=SIGEL(I)-SIGMA(I) 268 : 8 CONTINUE 269 : RETURN 270 : C 271 : 309 ICAS=0 272 : IF(DLAMBD(IC1).GT.0.D0.AND.DLAMBD(IC2).GT.0.D0) ICAS=IC1+IC2-2 273 : IF(DLAMBD(IC1).GT.0.D0.AND.DLAMBD(IC3).GT.0.D0) ICAS=IC1+IC3-2 274 : IF(DLAMBD(IC2).GT.0.D0.AND.DLAMBD(IC3).GT.0.D0) ICAS=IC2+IC3-2 275 : IF(ICAS.NE.0) GO TO 312 276 : C 277 : C IL N Y A PAS NI DE TRIPLAGE NI DE COUPLAGE 278 : C 279 : IF(DLAMBD(IC1).GT.0.D0) ICRIT1=IC1 280 : IF(DLAMBD(IC2).GT.0.D0) ICRIT1=IC2 281 : IF(DLAMBD(IC3).GT.0.D0) ICRIT1=IC3 282 : C 283 : ICRIME=IC1 284 : ICRIMT=IC2 285 : IF(ICRIT1.EQ.IC1) ICRIME=IC3 286 : IF(ICRIT1.EQ.IC2) ICRIMT=IC3 287 : C 288 : ICOUP=1 289 : XX=0.D0 290 : DLAMBD(IC1)=DLAM01 291 : DLAMBD(IC2)=DLAM02 292 : DLAMBD(IC3)=DLAM03 293 : VMELAS=VMELA0 294 : DPELA2=DPEL20 295 : PORELA=POREL0 296 : RETURN 297 : C 298 : C IL N Y A PAS DE TRIPLAGE MAIS IL Y A COUPLAGE 299 : C 300 : 312 ICOUP=2 301 : IF(DLAMBD(IC1).EQ.0.D0) ICRIMT=IC1 302 : IF(DLAMBD(IC2).EQ.0.D0) ICRIMT=IC2 303 : IF(DLAMBD(IC3).EQ.0.D0) ICRIMT=IC3 304 : C 305 : XX=0.D0 306 : DLAMBD(IC1)=DLAM01 307 : DLAMBD(IC2)=DLAM02 308 : DLAMBD(IC3)=DLAM03 309 : VMELAS=VMELA0 310 : DPELA2=DPEL20 311 : PORELA=POREL0 312 : RETURN 313 : C 314 : C IL N Y A PAS D ENDOMMAGEMENT 315 : C 316 : 313 ICOUP=0 317 : XX=0.D0 318 : DLAMBD(IC1)=DLAM01 319 : DLAMBD(IC2)=DLAM02 320 : DLAMBD(IC3)=DLAM03 321 : VMELAS=VMELA0 322 : DPELA2=DPEL20 323 : PORELA=POREL0 324 : C 325 : 900 FORMAT(1X,'ERREUR DANS TRIPLE - NON CONVERGENCE '/ 326 : . 1X,'ICRIT1=',I4,1X,'TEST1 =',1PE12.5,/, 327 : . 1X,'ICRIT2=',I4,1X,'TEST2 =',1PE12.5,/, 328 : . 1X,'ICRIT3=',I4,1X,'TEST3 =',1PE12.5) 329 : 901 FORMAT(1X,'ERREUR DANS TRIPLE: DLAMBD(',I1,')=',1PD12.5,1X, 330 : .'DLAMBD(',I1,')=',1PD12.5,1X,'DLAMBD(',I1,')=',1PD12.5) 331 : 3001 FORMAT(1X,'SIGEL =',6(1X,1PD12.5)) 332 : 3002 FORMAT(1X,'DSIGP =',6(1X,1PD12.5)) 333 : 3003 FORMAT(1X,'SIGMAT=',6(1X,1PD12.5)) 334 : 3004 FORMAT(1X,'C =',3(1X,1PD12.5)) 335 : 3005 FORMAT(1X,'DDLAM =',3(1X,1PD12.5)) 336 : 3006 FORMAT(1X,'DF1 =',6(1X,1PD12.5)) 337 : 3007 FORMAT(1X,'DF2 =',6(1X,1PD12.5)) 338 : 3008 FORMAT(1X,'DF3 =',6(1X,1PD12.5)) 339 : 3009 FORMAT(1X,'SIG =',6(1X,1PD12.5)) 340 : C 341 : RETURN 342 : END 343 :
© Cast3M 2003 - All rights reserved.
Disclaimer