1 : C PRJDRU SOURCE CHAT 05/01/13 02:28:02 5004 2 : SUBROUTINE PRJDRU(SSTAR,SELAS,PENTE,IBOU,SI,DEPS,EPST, 3 : . EPSTAR,ITER,SN,DHOOK,AM,A,BM,XMAT,YUNG,XNU,LAPOIN,KERRE, 4 : & ecou,necou) 5 : * 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL *8(A-H,O-Z) 8 : DIMENSION AM(*),A(*),BM(*),XMAT(*),DHOOK(*) 9 : -INC CCOPTIO 10 : * 11 : SEGMENT ECOU 12 : *** COMMON/ECOU/TEST,ALFAH, 13 : REAL*8 TEST, ALFAH, 14 : 1 HPAS,TEMPS,COVNMS(6),VECPRO(9),VALPRO(6), 15 : 2 CVNMSD(12),STOT(6),SIGEL(6),DSIGP(6),SIGT(6),W1(6),W2(6), 16 : 1 DALPHA(6),EPSPLA(6),E(12),XINV(3), 17 : 2 SIPLAD(6),DSIGP0(6),TET,TETI 18 : ENDSEGMENT 19 : C COMMON/ECOU/TEST,ALFAH, 20 : C . HPAS,TEMPS,COVNMS(6),VECPRO(9),VALPRO(6), 21 : C . CVNMSD(12),STOT(6),SIGEL(6),DSIGP(6),SIGT(6),W1(6),W2(6), 22 : C . DALPHA(6),EPSPLA(6),E(12),XINV(3), 23 : C . SIPLAD(6),DSIGP0(6),TET,TETI 24 : * 25 : SEGMENT NECOU 26 : * COMMON/NECOU/NCOURB,IPLAST,IT,IMAPLA,ISOTRO, 27 : INTEGER NCOURB,IPLAST,IT,IMAPLA,ISOTRO, 28 : . ITYP,JFOUR,IFLUAG, 29 : . ICINE,ITHER,IFLUPL,ICYCL,IBI, 30 : . JFLUAG,LEGAUS,LFLUAG, 31 : . IRELAX,JNTRIN,MFLUAG,JELEM,JGRDEF 32 : ENDSEGMENT 33 : C COMMON/NECOU/NCOURB,IPLAST,IT,IMAPLA,ISOTRO, 34 : C . ITYP,JFOUR,IFLUAG, 35 : C . ICINE,ITHER,IFLUPL,ICYCL,IBI, 36 : C . JFLUAG,LEGAUS,LFLUAG, 37 : C . IRELAX,JNTRIN,MFLUAG,JELEM,JGRDEF 38 : * 39 : DATA COEPT/1.D-3/ 40 : DATA ITMAX/25/ 41 : * 42 : * QUELQUES INITIALISATIONS 43 : * 44 : IIMPI0=IIMPI 45 : JEBOUC=0 46 : 2020 JEBOUC=JEBOUC+1 47 : KERRE=0 48 : LESN0 =0 49 : LAPOIN=0 49 : CALL ZDANUL(AM,36) 49 : CALL ZDANUL(W2,6) 49 : CALL ZDANUL(EPSPLA,6) 50 : XMATE =XMAT(1) 51 : XMATM =XMAT(2) 52 : XMATKL=XMAT(3) 53 : XMATC =XMAT(4) 54 : XMATD =XMAT(5) 55 : PEPSI =SQRT(2.D0*XMATC*XMATC+XMATD*XMATD) 56 : PENTE =XMAT(9)*PEPSI 57 : PENTF=PENTE 58 : * 59 : IF(IIMPI.EQ.15) THEN 60 : WRITE(IOIMP,77991) YUNG,XNU,ITYP,IMAPLA,PEPSI 61 : 77991 FORMAT('0 PRJDRU YUNG=',1PE12.5,2X,'XNU=',1PE12.5/ 62 : . 2X,'ITYP=',I4,2X,'IMAPLA=',I4,2X,'PEPSI=',1PE12.5/) 63 : WRITE(IOIMP,77992) (XMAT(IJ),IJ=1,9) 64 : 77992 FORMAT('0 PRJDRU XMAT ' /(3(1X,1PE12.5))) 65 : WRITE(IOIMP,77995) SSTAR,SELAS,EPSTAR 66 : 77995 FORMAT('0 PRJDRU SSTAR=',1PE12.5,2X,'SELAS=',1PE12.5,2X, 67 : . 'EPSTAR=',1PE12.5/) 68 : ENDIF 69 : * 70 : * CALCUL DE LA MATRICE DE HOOKE ( ISOTROPE ONLY | ) 71 : * 71 : CALL HOOINC(DHOOK,YUNG,XNU,ITYP) 72 : * 73 : GO TO (101,102,103,104,105,106,107,108,109),ITYP 74 : 101 CONTINUE 75 : DO 1010 IA=1,3 76 : AM((IA-1)*6+IA) =1.D0 77 : AM((IA-1)*6+21+IA)=3.0D0 78 : W2(IA)=1.D0 79 : 1010 CONTINUE 80 : AM(2)=-0.5D0 81 : AM(3)=-0.5D0 82 : AM(7)=-0.5D0 83 : AM(9)=-0.5D0 84 : AM(13)=-0.5D0 85 : AM(14)=-0.5D0 86 : GO TO 200 87 : 102 CONTINUE 88 : * ON SAUVE D COMPACTE SUR 10 VALEURS DANS CVNMSD 88 : CALL SHIFTD(DHOOK,CVNMSD,10) 88 : CALL ZDANUL(DHOOK,36) 89 : DHOOK(1)=CVNMSD(1) 90 : DHOOK(2)=CVNMSD(2) 91 : DHOOK(7)=CVNMSD(3) 92 : DHOOK(8)=CVNMSD(4) 93 : DHOOK(15)=CVNMSD(5) 94 : DHOOK(22)=CVNMSD(6) 95 : DHOOK(23)=CVNMSD(7) 96 : DHOOK(28)=CVNMSD(8) 97 : DHOOK(29)=CVNMSD(9) 98 : DHOOK(36)=CVNMSD(10) 99 : DO 1020 IA=1,2 100 : AM(6*(IA-1)+IA)=ALFAH 101 : AM(6*(IA-1)+21+IA)=1.D0 102 : W2(3+IA)=1.D0 103 : 1020 CONTINUE 104 : AM(2)=-0.5D0*ALFAH 105 : AM(7)=-0.5D0*ALFAH 106 : AM(15)=3.0D0*ALFAH 107 : AM(23)=-0.5D0 108 : AM(28)=-0.5D0 109 : AM(36)=3.0D0 110 : GO TO 200 111 : 103 CONTINUE 111 : CALL SHIFTD(DHOOK,CVNMSD,10) 111 : CALL ZDANUL(DHOOK,36) 112 : DHOOK(1)=CVNMSD(1) 113 : DHOOK(2)=CVNMSD(2) 114 : DHOOK(7)=CVNMSD(3) 115 : DHOOK(8)=CVNMSD(4) 116 : DHOOK(15)=CVNMSD(5) 117 : DHOOK(22)=CVNMSD(6) 118 : DHOOK(23)=CVNMSD(7) 119 : DHOOK(28)=CVNMSD(8) 120 : DHOOK(29)=CVNMSD(9) 121 : DHOOK(36)=CVNMSD(10) 122 : AM(1)= 1.D0 123 : AM(2)=-0.5D0 124 : AM(7)=-0.5D0 125 : AM(8)= 1.D0 126 : AM(15)=3.0D0 127 : W2(1)= 1.D0 128 : W2(2)= 1.D0 129 : GO TO 200 130 : 104 CONTINUE 131 : AM(15)=1.D0 132 : W2(3)=1.D0 133 : GO TO 200 134 : 105 CONTINUE 135 : AM(1)=0.5D0*(COVNMS(2)+COVNMS(3)) 136 : AM(8)=0.5D0*(COVNMS(1)+COVNMS(3)) 137 : AM(15)=0.5D0*(COVNMS(2)+COVNMS(1)) 138 : AM(2)=-0.5D0*COVNMS(3) 139 : AM(3)=-0.5D0*COVNMS(2) 140 : AM(7)=-0.5D0*COVNMS(3) 141 : AM(9)=-0.5D0*COVNMS(1) 142 : AM(13)=-0.5D0*COVNMS(2) 143 : AM(14)=-0.5D0*COVNMS(1) 144 : AM(22)=-0.5D0*COVNMS(4) 145 : AM(29)=-0.5D0*COVNMS(5) 146 : AM(36)=-0.5D0*COVNMS(6) 147 : DO 10005 IB=1,3 148 : 10005 W2(IB)=1.D0 149 : GO TO 200 150 : 106 CONTINUE 151 : AM(1) =1.D0 152 : AM(8) =1.D0 153 : AM(15)=1.D0 154 : AM(2)=-0.5D0 155 : AM(3)=-0.5D0 156 : AM(7)=-0.5D0 157 : AM(9)=-0.5D0 158 : AM(13)=-0.5D0 159 : AM(14)=-0.5D0 160 : AM(22)=3.0D0 161 : W2(1)=1.D0 162 : W2(2)=1.D0 163 : W2(3)=1.D0 164 : GO TO 200 165 : 107 CONTINUE 166 : AM(1)=ALFAH 167 : AM(22)=1.D0 168 : W2(4)=1.D0 169 : GO TO 200 170 : 108 CONTINUE 171 : AM(1)=1.D0 172 : W2(1)=1.D0 173 : GO TO 200 174 : 109 CONTINUE 175 : * 176 : 200 CONTINUE 177 : TST=TEST*0.3333333333D0*(DHOOK(1)+DHOOK(8)+DHOOK(15))*COEPT 178 : TST10=TST*1.D1 179 : IF(IIMPI.EQ.15) WRITE(IOIMP,77883) TST,DHOOK(1),DHOOK(8), 180 : . DHOOK(15),TEST,COEPT 181 : 77883 FORMAT('0 PRJDRU - TST=',1PE12.5/2X, 182 : . 'DHOOK(1)=',1PE12.5,2X,'DHOOK(8)=',1PE12.5,2X, 183 : . 'DHOOK(15)=',1PE12.5/'0 TEST=',1PE12.5,2X, 184 : . 'COEPT=',1PE12.5/) 185 : * 186 : * INITIALISATIONS AVANT ITERATIONS 187 : * 188 : ITER =0 189 : EPSTA0 = EPSTAR/PEPSI 190 : EPST = EPSTA0 191 : SN = XMATKL+PENTE*EPSTA0 192 : * AM 24/5/93 TEST SUR SN 193 : IF(SN.LT.0.D0) THEN 194 : LESN0=1 195 : SN = 0.D0 196 : PENTF=0.D0 197 : ENDIF 198 : DEPS =0.D0 199 : DEPSI=0.D0 199 : CALL SHIFTD(STOT,SIGEL,6) 199 : CALL CKRIT(IMAPLA,SIGEL,ITYP,XMAT,ALFAH,COVNMS,XINV,SI) 200 : SJ1=XINV(1) 201 : SJ2=XINV(2) 202 : IF(IIMPI.EQ.15) THEN 203 : WRITE(IOIMP,77993) (SIGEL(IJ),IJ=1,IBOU) 204 : 77993 FORMAT('0 PRJDRU SIGEL ' /(6(1X,1PE12.5))) 205 : WRITE(IOIMP,77994) SN,SI,SJ1,SJ2 206 : 77994 FORMAT('0 PRJDRU SN=',1PE12.5,2X,'SI=',1PE12.5,2X, 207 : . 'SJ1=',1PE12.5,2X,'SJ2=',1PE12.5) 208 : ENDIF 209 : * 210 : * ------------------------------- 211 : * | LES ITERATIONS INTERNES | 212 : * ------------------------------- 213 : 555 CONTINUE 214 : ITER=ITER+1 215 : IF(IIMPI.EQ.15) WRITE(IOIMP,77886) ITER 216 : 77886 FORMAT('0 >>>>>>>>>>> PRJDRU - ITER =',I4/) 217 : * 218 : * AM 24/5/93 TEST SUR SJ2 219 : IF(IIMPI.EQ.15) WRITE(IOIMP,71886) SJ2,TST10 220 : 71886 FORMAT('0 SJ2=',1PE12.5,2X,'TST10=',1PE12.5/) 221 : IF(SJ2.LT.TST10) GO TO 6 222 : * 223 : 1108 CONTINUE 224 : DO 1013 IM=1,IBOU 225 : 1013 DALPHA(IM) = SIGEL(IM) 225 : CALL MULMAT(W1,AM,SIGEL,6,1,6) 226 : IF(IIMPI.EQ.15) WRITE(IOIMP,72677) (W1(IJ),IJ=1,6) 227 : 72677 FORMAT(1X,' W1 '/(6(1X,1PE12.5))) 228 : ELTB=XMATD/SJ2 229 : ELT =XMATM/SJ2 229 : CALL AEQBPC(SIPLAD,W1,W2,ELTB,XMATC,6) 230 : IF(IIMPI.EQ.15) WRITE(IOIMP,73677) (SIPLAD(IJ),IJ=1,6) 231 : 73677 FORMAT(1X,' SIPLAD '/(6(1X,1PE12.5))) 231 : CALL AEQBPC(W1,W1,W2,ELT,XMATE,6) 232 : IF(IIMPI.EQ.15) WRITE(IOIMP,73674) (W1(IJ),IJ=1,6) 233 : 73674 FORMAT(1X,' W1 '/(6(1X,1PE12.5))) 233 : CALL MULMAT(DSIGP0,DHOOK,SIPLAD,6,1,6) 234 : IF(IIMPI.EQ.15) WRITE(IOIMP,73675) (DSIGP0(IJ),IJ=1,6) 235 : 73675 FORMAT(1X,' DSIGP0 '/(6(1X,1PE12.5))) 236 : ELT1=SDOT(IBOU,W1,1,DSIGP0,1) 237 : DEPSI=(SI-SN)/(ELT1+PENTF+1.E-20) 238 : DEPS = DEPS+DEPSI 239 : IF(IIMPI.EQ.15) WRITE(IOIMP,77888) DEPSI,DEPS 240 : 77888 FORMAT('0 PRJDRU - DEPSI=',1PE12.5,2X,'DEPS=',1PE12.5/) 241 : IF(DEPS.LT.0.D0) GO TO 5 242 : EPST = EPSTA0+DEPS 243 : IF(LESN0.EQ.0) SN=XMATKL+PENTE*EPST 244 : IF(IIMPI.EQ.15) WRITE(IOIMP,77812) XMATKL,PENTE,EPST,SN 245 : 77812 FORMAT('0 PRJDRU - XMATKL',1PE12.5,2X,'PENTE=',1PE12.5, 246 : . 2X,'EPST=',1PE12.5,2X,'SN=',1PE12.5/) 247 : * 248 : * AM 24/5/93 TEST SUR SN 249 : IF(SN.LT.0.D0) THEN 250 : SN=0.D0 251 : PENTF=0.D0 252 : LESN0=1 253 : * AM 12/8/93 ON REMBOBINE 254 : DEPS = DEPS-DEPSI 255 : ITER=ITER-1 256 : IF(IIMPI.EQ.15) WRITE(IOIMP,71108) 257 : 71108 FORMAT('0 ****** PRJDRU - ON REMBOBINE '/) 258 : GO TO 1108 259 : ENDIF 260 : DO 867 I=1,IBOU 261 : 867 EPSPLA(I)=EPSPLA(I)+SIPLAD(I)*DEPSI 261 : CALL AEQBPC(SIGEL,SIGEL,DSIGP0,1.D0,-DEPSI,6) 262 : * 263 : * PETITE MODIF 19/8/92 264 : * 265 : IF(MOD(ITER,5).EQ.0) THEN 266 : DO 1014 IM=1,IBOU 267 : 1014 SIGEL(IM)=(SIGEL(IM)+DALPHA(IM))*0.5D0 268 : ENDIF 268 : CALL CKRIT(IMAPLA,SIGEL,ITYP,XMAT,ALFAH,COVNMS,XINV,SI) 269 : SJ1=XINV(1) 270 : SJ2=XINV(2) 271 : * AM 24/5/93 272 : * SI XMATE=0 PAS DE PB DE SOMMET 273 : * SINON, SI ON DEPASSE LE SOMMET, ON PROJETTE DESSUS 274 : * 275 : IF(XMATE.EQ.0.D0) GO TO 210 276 : XI1LIM=SN/XMATE 277 : IF(IIMPI.EQ.15) WRITE(IOIMP,77811) SJ1,SN,XI1LIM,SJ2 278 : 77811 FORMAT('0 PRJDRU - SJ1=',1PE12.5,2X,' SN =',1PE12.5, 279 : . 2X,'XI1LIM=',1PE12.5,2X,'SJ2=',1PE12.5/) 280 : IF(SJ1.GT.XI1LIM) GO TO 6 281 : 210 CONTINUE 282 : STST=ABS(SI-SN) 283 : * 284 : IF(IIMPI.EQ.15) THEN 285 : WRITE(IOIMP,77887) SI,SN,STST,TST,EPST 286 : 77887 FORMAT('0 PRJDRU - SI=',1PE12.5,2X,'SN=',1PE12.5,2X, 287 : . 'STST=',1PE12.5,2X,'TST=',1PE12.5/2X,'EPST=',1PE12.5) 288 : WRITE(IOIMP,77677) (SIGEL(IJ),IJ=1,IBOU) 289 : 77677 FORMAT(1X,'NOUVELLE SOLUTION'/(6(1X,1PE12.5))) 290 : WRITE(IOIMP,71677) (EPSPLA(IJ),IJ=1,IBOU) 291 : 71677 FORMAT(1X,'NOUVELLE DEF PLA'/(6(1X,1PE12.5))) 292 : ENDIF 293 : * 294 : IF(STST.LE.TST) GO TO 3 295 : IF(ITER.GT.ITMAX) GO TO 4 296 : GO TO 555 297 : * 298 : * PROJECTION AU SOMMET 299 : * 300 : 6 CONTINUE 301 : IF(IIMPI.EQ.15) WRITE(IOIMP,77387) 302 : 77387 FORMAT('0 PRJDRU - ON VA PROJETTER AU SOMMET ') 302 : CALL SOMDRU(IBOU,SI,DEPS,EPST,EPSTAR,SN,XMAT,YUNG, 303 : . XNU,PENTF,KERRE,ecou,necou) 304 : LAPOIN=1 305 : GO TO 33 306 : * 307 : 5 CONTINUE 308 : KERRE=1 309 : GO TO 34 310 : 4 CONTINUE 311 : KERRE=2 312 : 34 CONTINUE 313 : IF (JEBOUC.EQ.1) THEN 314 : IIMPI=15 315 : GO TO 2020 316 : ELSE 317 : IIMPI=IIMPI0 318 : ENDIF 319 : 3 CONTINUE 320 : IF(IIMPI.EQ.15) WRITE(IOIMP,66554) (EPSPLA(IB),IB=1,IBOU) 321 : 66554 FORMAT('0 SORTIE DE PRJDRU - EPSPLA ' /1X,6(1X,1PE12.5)/) 322 : IF(IIMPI.EQ.15) WRITE(IOIMP,61554) DEPS,EPST 323 : 61554 FORMAT('0 SORTIE DE PRJDRU - DEPS = ',1PE12.5,2X,'EPST=', 324 : . 1PE12.5) 325 : DEPS=DEPS*PEPSI 326 : EPST=EPST*PEPSI 327 : 33 CONTINUE 327 : IF(ITYP.EQ.2.OR.ITYP.EQ.3) CALL ZDANUL(DHOOK,36) 327 : IF(ITYP.EQ.2.OR.ITYP.EQ.3) CALL SHIFTD(CVNMSD,DHOOK,10) 328 : RETURN 329 : END 330 : 331 : 332 : 333 : 334 :
© Cast3M 2003 - All rights reserved.
Disclaimer