1 : C CALPEC SOURCE CHAT 05/01/12 21:47:45 5004 2 : SUBROUTINE CALPEC(IFOU,STRN,SIGR,SIGM,S1,DEP,NSTRS,SEQC, 3 : 1 EBC,EPEQC,EPSR,STRNR,JFRIS,IPLA,EPEQ0,SEQ0,XE,NBNN,MELE,EQSTR1, 4 : 2 EPSEQ1,AA,BB,DK1,DK2,ILOI,RB,ALPHA,EX,PXY,EPO,wrk12) 5 : C 6 : IMPLICIT INTEGER(I-N) 7 : IMPLICIT REAL*8(A-H,O-Z) 8 : DIMENSION STRNR(6),EPSR(6),SIGR(6),S(6) 9 : DIMENSION S1(NSTRS),DFSI(6),STRN(NSTRS),DGSI(6) 10 : DIMENSION DEP(NSTRS,NSTRS),D6(6,6),DP(6,6),S11(6) 11 : DIMENSION SIGM(NSTRS),V1(4),SS(100,6),CR(100,3) 12 : DIMENSION SI0(6),ST0(6),DST(6),DSI(6),XE(3,NBNN) 13 : C 14 : SEGMENT WRK12 15 : real*8 bbet1,bbet2,bbet3,bbet4,bbet5,bbet6,bbet7,bbet8,bbet9 16 : real*8 bbet10,bbet11,bbet12,bbet13,bbet14,bbet15,bbet16,bbet17 17 : real*8 bbet18,bbet19,bbet20,sct,teta,DTR1,dtr2,bbet25 18 : real*8 bbet26,bbet27,bbet28,bbet29,bbet30,bbet31,bbet32,bbet33 19 : real*8 bbet34,bbet35,bbet36,bbet37,bbet38,bbet39,bbet40,bbet41 20 : real*8 bbet42,bbet43,bbet44,bbet45,bbet46,bbet47,bbet48,bbet49 21 : real*8 bbet50,bbet51,bbet52,bbet53,bbet54,bbet55 22 : integer ibet1,ibet2,ibet3,ibet4,ibet5,ibet6,ibet7,ibet8 23 : integer ibet9,ibet10,ibet11,ibet12,ibet13,ibet14,ibet15,ibet16 24 : ENDSEGMENT 25 : 26 : * COMMON /CINSA/ POUI(20),SCT,TETA,DTR1,DTR2,POUJ(31),IPOU(16) 27 : C------------------------------------------------------------------- 27 : CALL ZERO(S1,NSTRS,1) 27 : CALL ZERO(DEP,NSTRS,NSTRS) 28 : C 29 : TU=RB 30 : PRB=1.D-5 31 : NIB=2 32 : ICHOI=1 33 : IPREM=0 34 : C------------------------------------------------------------------- 35 : SCT =0.D0 36 : DTR1=0.D0 37 : DTR2=0.D0 38 : TETA=0.D0 39 : FPT=ALPHA*RB 40 : C------------------------------------------------------------------- 41 : BETC=EBC/EX 42 : PAEC0=EBC/(1.D0-BETC) 42 : CALL CRIOTO(SIGR,SEQ,FCRI,NSTRS,TU,AA,BB,DK1,DK2) 43 : IF(SEQ.LT.1.D-10) IPREM=1 44 : IF(SEQ.GT.TU) SEQ=TU 45 : C------------------------------------------------------------------- 46 : DO 10 I=1,NSTRS 47 : S11(I)=SIGR(I)+SIGM(I) 48 : IF(IPREM.EQ.0) THEN 49 : S1(I)=SIGR(I) 50 : ELSE 51 : S1(I)=S11(I) 52 : ENDIF 53 : 10 CONTINUE 54 : C------------------------------------------------------------------- 55 : IF(EPSEQ1.GE.EPO) THEN 56 : C ------------------------------------------------------------- 57 : C * ON AVAIT DEJA DEPASSE LE PIC EN DEFORMATION EQUIVALENTE * 58 : C ------------------------------------------------------------- 58 : CALL PRINC(SIGR,V1,NSTRS) 59 : IF(V1(1).GE.0.D0) THEN 60 : DTR1=V1(1) 61 : DTR2=FPT 62 : IF(DTR1.LT.0.D0) DTR1=0.D0 63 : IF(DTR1.GE.FPT) DTR1=FPT 64 : IF(DTR1.LT.1.D-8) DTR1=0.D0 65 : TETA=V1(4) 66 : DO 21 I=1,NSTRS 67 : SI0(I)=SIGR(I) 68 : ST0(I)=EPSR(I) 69 : DSI(I)=SIGM(I) 70 : DST(I)=STRN(I) 71 : 21 CONTINUE 72 : JFRIS=2 73 : IPLA=0 73 : CALL FISPLA(ST0,DST,STRNR,SI0,DSI,S1,NSTRS,IFOU,0,XE, 74 : 1 NBNN,MELE,wrk12) 75 : GOTO 200 76 : ENDIF 77 : ENDIF 78 : C------------------------------------------------------------------- 79 : IF(IPREM.EQ.1) THEN 80 : IF(NIB.EQ.1) NIB = 10 80 : CALL CRIOTO(S1,SEQ,FCRI,NSTRS,TU,AA,BB,DK1,DK2) 81 : ENDIF 82 : C------------------------------------------------------------------- 83 : IF(IPREM.EQ.0.AND.SEQ.GT.TU) SEQ=TU 84 : SEQ0=SEQ 85 : IF(SEQ0.LT.1.D-8.AND.SEQC.LT.1.D-8) THEN 85 : CALL ZERO(S1,NSTRS,1) 86 : GOTO 200 87 : ENDIF 88 : IF(SEQ0.LT.1.D-8.AND.SEQC.GT.1.D-8) THEN 89 : SEQ=SEQC 90 : ENDIF 91 : C------------------------------------------------------------------- 91 : CALL ZERO(CR,100,3) 91 : CALL ZERO(SS,100,6) 92 : C------------------------------------------------------------------- 93 : DO 1 II=1,NIB 94 : C------------------------------------------------------------------- 95 : SEQ1=SEQ 96 : IF(SEQ1.GT.TU) SEQ1=TU 97 : IF(SEQ.LT.1.D-8) THEN 98 : IPLA=4 99 : GOTO 300 100 : ENDIF 101 : C------------------------------------------------------------------- 102 : C ************************************** 103 : C * BOUCLE SUR LES ITERATIONS INTERNES * 104 : C ************************************** 105 : C------------------------------------------------------------------- 105 : CALL DFSIG(S1,DFSI,DGSI,SEQ1,NSTRS,RB,AA,BB,DK1,DK2,ILOI) 106 : H2=0.D0 107 : DO 92 I=1,NSTRS 108 : H2=H2+DFSI(I)*DGSI(I) 109 : 92 CONTINUE 110 : PAEC=PAEC0*H2 111 : C------------------------------------------------------------------- 111 : CALL DEPO(S1,DEP,PAEC,SEQ1,NSTRS,IFOU,D6,DP,EX,PXY,AA,BB, 112 : & DK1,DK2,RB,ILOI) 112 : CALL BST(DEP,STRN,NSTRS,NSTRS,S) 113 : DO 45 I=1,NSTRS 114 : S1(I)=SIGR(I)+S(I) 115 : 45 CONTINUE 115 : CALL CRIOTO(S1,SEQ,FCRI,NSTRS,SEQ1,AA,BB,DK1,DK2) 116 : IF(SEQ.GT.SEQ0.AND.EPEQ0.GT.(1.1D0*EPO)) THEN 117 : IPLA=4 118 : GOTO 300 119 : ENDIF 120 : C--------------------------------------------------------------------- 121 : IF(DABS(FCRI).LT.PRB) GOTO 7 122 : DO 4 J=1,NSTRS 123 : SS(II,J)=S1(J) 124 : 4 CONTINUE 125 : CR(II,1)=FCRI 126 : CR(II,2)=SEQ 127 : CR(II,3)=PAEC 128 : C------------------------------------------------------------------- 129 : C ************************************************ 130 : C * FIN DE LA BOUCLE SUR LES ITERATIONS INTERNES * 131 : C ************************************************ 132 : 1 CONTINUE 133 : c+mdj 134 : C GOTO 7 135 : c+mdj 136 : C-------------------------------------------------------------------------- 137 : DMMN1=DABS(CR(1,1)) 138 : NO=1 139 : DO 5 J=1,NIB 140 : ACR=DABS(CR(J,1)) 141 : IF(DMMN1 .GE. ACR) THEN 142 : DMMN1=DABS(CR(J,1)) 143 : NO=J 144 : ENDIF 145 : 5 CONTINUE 146 : DO 6 J=1,NSTRS 147 : S1(J)=SS(NO,J) 148 : 6 CONTINUE 149 : SEQ=CR(NO,2) 150 : PAEC=CR(NO,3) 151 : 7 CONTINUE 152 : C---------------------------------------------------------------------- 153 : IF(SEQ.GT.TU) SEQ=TU 153 : CALL DEPO(S1,DEP,PAEC,SEQ,NSTRS,IFOU,D6,DP,EX,PXY,AA,BB, 154 : 1 DK1,DK2,RB,ILOI) 155 : C------------------------------------------------------------------- 156 : IF(SEQ.GT.EQSTR1) THEN 157 : C ------------------------------------- 158 : DO I=1,NSTRS 159 : DSI(I)=S1(I)-SIGR(I) 160 : END DO 160 : CALL SCALT(DSI,SIGR,SI0,V1,SCT,NSTRS,DTAU,EQSTR1,AA,BB,DK1, 161 : & DK2,ALPHA,RB,DTR1,DTR2,TETA) 162 : C ------------------------------------- 163 : IF(V1(1).GE.0.D0) THEN 164 : DTR1=V1(1) 165 : DTR2=FPT 166 : TETA=V1(4) 167 : IF(DTR1.LT.0.D0) DTR1=0.D0 168 : IF(DTR1.GE.FPT) DTR1=FPT 169 : IF(DTR1.LT.1.D-8) DTR1=0.D0 170 : JFRIS=2 171 : IPLA=0 171 : CALL FISPLA(EPSR,STRN,STRNR,SIGR,DSI,S1,NSTRS,IFOU,0,XE, 172 : 1 NBNN,MELE,wrk12) 173 : GOTO 200 174 : ENDIF 175 : C ------------------------------------- 176 : DTR1=0.D0 177 : DTR1=0.D0 178 : DTR1=0.D0 179 : TETA=0.D0 180 : SCT =0.D0 181 : IPLA=4 182 : C ------------------------------------- 183 : ENDIF 184 : C------------------------------------------------------------------- 185 : 300 CONTINUE 186 : IF(IPLA.EQ.4) THEN 186 : CALL ZERO(DEP,NSTRS,NSTRS) 186 : CALL ZERO(S1,NSTRS,1) 187 : EPSEQ1=EPEQC 188 : EQSTR1=0.D0 189 : ENDIF 190 : C------------------------------------------------------------------- 191 : 200 CONTINUE 192 : C--------------------------------------------------------------------- 193 : 1991 FORMAT(18(1X,E12.5)) 194 : RETURN 195 : END 196 : 197 : 198 : 199 : 200 :
© Cast3M 2003 - All rights reserved.
Disclaimer