C OTTOCA SOURCE FANDEUR 22/05/02 21:15:27 11359 C responsable MILLARD SUBROUTINE OTTOCA(SIG0,DEPST,W,WMAX,XLAMC, & SMAX,WRUPT,BILIN,SBILI,XLTR,XLCS,XINVL, & WREOUV,YOUN,XNU,GFTR,GFCS,G,GS,BTR,XCOMP, & NFISSU,NVF,VF,XX,IRESU,NRESU, & SIGF,DEFP,PRECIE,PRECIZ,MFR,KERRE) C---------------------------------------------------------------------- C ECOULEMENT OTTOSEN C---------------------------------------------------------------------- C C ENTREES : SIG0,DEPST,PRECIE,PRECIZ,MFR,KERRE C C SORTIES : SIGF,DEFP C C C RAPPEL : EN DEFO PLANES,CONTRAINTES PLANES OU AXI, C LA DIRECTION 1 EST CELLE PERPENDICULAIRE AU MAILLAGE C C----------------------------------------------------------------------- C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC PPARAM -INC CCOPTIO * PARAMETER (XZER=0.D0,NC=4) DIMENSION SIG0(*),DEPST(*),SIGF(*),DEFP(*),XCOMP(*),GFTR(*) DIMENSION STOT(6),SIGEL(6),DELAS(6),DEFPLA(6),DEPSTT(6) DIMENSION DSIGT(6) ,DDPLAS(6) DIMENSION SIG1(6) ,SIG2(6) DIMENSION SAUX(6) * DIMENSION DD(18),GS(3) DIMENSION W(3),WMAX(3),BILIN(3),WREOUV(3),SMAX0(3) DIMENSION WRUPT(3),XLTR(3),XINVL(3),SBILI(3),W0(3),WMAX0(3) DIMENSION VF(3,3),JFIS(3),DXV1(3),DXV2(3) * DIMENSION DDE(18) DIMENSION DEPST0(6) * DIMENSION SMAX(*),IRESU(*) * DIMENSION NN(NC),FC(NC),FC2(NC),FCC(NC) DIMENSION MM(20),MM2(20),FCV(20),FCV1(20) * DIMENSION PENTE( 6),LEBIL( 6),ISING(NC) DIMENSION IFERM(NC),IBRUP(NC) DIMENSION PENTE2( 6),LEBIL2( 6),ISING2(NC) DIMENSION AA(NC+1,NC+1),BB1(NC+1),BB2(NC+1) DIMENSION DFDS(6,NC),DGDS(6,NC),HDFDQ(NC) DIMENSION DX(NC+1),DDX(NC+1) DIMENSION VEC1(NC+1),VEC2(NC+1) DIMENSION VAUX1(6),VAUX2(6),VAUX(6) DIMENSION DFF(6),DGG(6) REAL*8 DDOT EXTERNAL DDOT DATA ITMAX/150/ DATA IRMAX/5/ * * INITIALISATIONS * IRED=0 REFAC=1.D0 * DO I=1,3 W0(I)=W(I) WMAX0(I)=WMAX(I) WREOUV(I) = BTR*MIN(WMAX(I),WRUPT(I)) SMAX0(I)=SMAX(I) ENDDO XLAMC0=XLAMC * 888 CONTINUE * KERRE=0 NC1=NC+1 IRED=IRED+1 IF(IRED.GT.IRMAX) THEN PRINT *,'&&&&&&&& OTTOCA IRED = ',IRED KERRE=2 RETURN ENDIF * IF(IRED.GT.1) THEN DO I=1,3 W(I)=W0(I) WMAX(I)=WMAX0(I) WREOUV(I) = BTR*MIN(WMAX(I),WRUPT(I)) SMAX(I)=SMAX0(I) ENDDO XLAMC=XLAMC0 REFAC=REFAC*0.5D0 ENDIF * * MATRICE ELASTIQUE * CALL OTTODD(DDE,YOUN,XNU,G,GS,XINVL,W) * CALL SHIFTD(DEPST,DEPSTT,6) DO I=1,6 DEPSTT(I)=DEPSTT(I)*REFAC ENDDO * * SPECIAL CP * IF(IFOUR.EQ.-2) THEN DEPSTT(1)= (-DDE(6)*DEPSTT(2)-DDE(5)*DEPSTT(3))/DDE(1) ENDIF * * ON CALCULE L'INCREMENT DE CONTRAINTE EN ELASTIQUE * CALL OTTOPR(DDE,DEPSTT,DSIGT) CALL ZDANUL(PENTE,6 ) CALL ZDANUL(PENTE2,6 ) CALL IANUL(LEBIL,6 ) CALL IANUL(LEBIL2,6 ) CALL ZDANUL(AA,(NC+1)**2) CALL ZDANUL(BB1,NC+1) CALL ZDANUL(BB2,NC+1) CALL ZDANUL(DEFPLA,6) CALL ZDANUL(VAUX,6) CALL ZDANUL(VAUX1,6) CALL ZDANUL(VAUX2,6) CALL ZDANUL(DX,NC1) CALL ZDANUL(DXV1,3) CALL ZDANUL(DXV2,3) CALL IANUL(ISING2,NC) IF(IIMPI.EQ.42) THEN WRITE(IOIMP,76633) IRED,NFISSU,NVF,XLAMC,REFAC 76633 FORMAT(1X,' ENTREE DANS OTTOCA - IRED =',I4,2X, & ' NFISSU=',I4,2X,' NVF=',I4/ & 2X,'XLAMC=',1PE12.5,2X,' REFAC=',1PE12.5//) WRITE(IOIMP,74433) (DSIGT(I),I=1,6) 74433 FORMAT(1X,' DSIGT ',6(1X,1PE12.5)/) ENDIF * * write (6,*) ' pente avant ottoet dans ottoca ',(PENTE(IC),IC=1,4) CALL OTTOET(NC,NN,SIG0,W,WMAX,SMAX,BILIN,WRUPT,BTR, & XLTR,XINVL,SBILI,PRECIE,PRECIZ,FC,FC2, & LEBIL,NFISSU,NVF,VF,FCV,PENTE,PENTE2, & DX,DXV1,YOUN,NCA,MC,MM,ISING,IFERM, & IBRUP,IPLAS,XCOMP,XLAMC,DFF,DGG,KERRE) IF(KERRE.NE.0) RETURN * write (6,*) ' pente apres ottoet dans ottoca ',(PENTE(IC),IC=1,4) * IF(IIMPI.EQ.42) THEN PRINT *,' IPLAS = ',IPLAS ENDIF * ICOCRI=0 IF(ABS(FC(4)).LE.PRECIZ) ICOCRI=1 * * IF(IPLAS.NE.0) GO TO 88 * * * on essaye l'ecoulement elastique pur * ------------------------------------ * IF(IIMPI.EQ.42) THEN PRINT *,' ESSAI DU CAS ELASTIQUE' ENDIF * * MLR 9/7/99 * ICOMEL=0 IF(ABS(FC(4)).LE.PRECIZ) THEN IF(IIMPI.EQ.42) THEN WRITE(IOIMP,59502) (DSIGT(I),I=1,6) 59502 FORMAT(2X,' DSIGT ',6(1X,1PE12.5)/) WRITE(IOIMP,59503) (DFF(I),I=1,6) 59503 FORMAT(2X,' DFF ',6(1X,1PE12.5)/) ENDIF * TRA=0.D0 DO I=1,6 TRA = TRA + DFF(I)*DSIGT(I) ENDDO IF(IIMPI.EQ.42) THEN PRINT *,' ######## TRA = ',TRA ENDIF IF(TRA.LT.0.D0) ICOMEL=1 ENDIF * * RETRAITEMENT DE MM SI IFERM=1 * ET SI ICOMEL=0 * MC2=0 DO I=1,MC IF(MM(I).GE.4.AND.MM(I).LE.6) THEN IC=MM(I)-3 IF(IFERM(IC).EQ.1) GO TO 101 ENDIF * IF(MM(I).EQ.16.AND.ICOCRI.EQ.1.AND.ICOMEL.EQ.0) & GO TO 101 * MC2=MC2+1 MM2(MC2)=MM(I) 101 CONTINUE ENDDO * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,49102) MC2 49102 FORMAT(2X,' NOUVELLE VALEUR MC2 = ',I3/) WRITE(IOIMP,49103) (MM2(IC),IC=1,MC2) 49103 FORMAT(2X,' NOUVELLE LISTE MM2'/16(1X,I3)/) ENDIF * CALL OTTOXX(MC2,MM2,SIG0,DSIGT,STOT, & VAUX1,VAUX2,VAUX,FCV,DX,DXV1,DXV2, & PRECIE,PRECIZ,BTR,YOUN, & W,WMAX,SMAX,WRUPT,XLTR,XINVL,NFISSU,NVF,VF, & XX,IRESU,NRESU,XCOMP,XLAMC,ICOMEL,LERED,KERRE) IF(KERRE.NE.0) RETURN * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,44103) NRESU 44103 FORMAT(1X,' SORTIE DE OTTOXX NRESU=',I3/) WRITE(IOIMP,48103) (IRESU(I),I=1,NRESU) 48103 FORMAT(1X,' IRESU '/10I4/) PRINT *,'XX =',XX ENDIF * IF(NCA.EQ.0) THEN IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77003) 77003 FORMAT(1X,' :::::::::::::::::::::::' / & 1X,' SORTIE ELASTIQUE ' / & 1X,' :::::::::::::::::::::::' /) ENDIF * IF(XX.LE.0.D0) THEN KERRE=2 PRINT *,' XX EST NEGATIF OU NUL ' PRINT *,'XX=',XX RETURN ENDIF * GO TO 89 ELSE * CALL IANUL(LEBIL2,NC) * write (6,*) ' pente avant ottocr dans ottoca ',(PENTE(IC),IC=1,4) CALL OTTOCR(NCA,NN,STOT,W,WMAX,SMAX,BILIN,WRUPT,BTR, & XLTR,XINVL,SBILI,FCC,PENTE2,LEBIL2, & PRECIE,PRECIZ,XCOMP,XLAMC,KERRE) IF(KERRE.NE.0) RETURN * write (6,*) ' pente apres ottocr dans ottoca ',(PENTE(IC),IC=1,4) * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,72093) (FCC(IJ),IJ=1,NC) 72093 FORMAT(1X,' FCC ',(4(1X,1PE12.5))/) ENDIF * IELAS=1 DO IJ=1,NCA JJ=NN(IJ) IF (FCC(JJ).GT.PRECIZ) IELAS=0 ENDDO * IF(IELAS.EQ.1) THEN IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77003) ENDIF * GO TO 89 ENDIF * ENDIF * * * cas de l'ecoulement elastoplastique * ----------------------------------- * 88 CONTINUE IF(IIMPI.EQ.42) THEN WRITE(IOIMP,70378) 70378 FORMAT(/2X,' ON ATTAQUE LE CAS PLASTIQUE '//) ENDIF * * INITIALISATIONS * ITER =0 DO I=1,6 DEPST0(I)=DEPSTT(I) STOT(I)=SIG0(I) ENDDO * DO I=1,NC ISING(I)=0 IF(LEBIL(I).EQ.2) ISING(I)=1 ENDDO * * write (6,*) ' pente avant ottoin dans ottoca ',(PENTE(IC),IC=1,4) IF(ISING(1)+ISING(2)+ISING(3).NE.0.OR. & (IFERM(4).EQ.1.AND.NCA.GE.2)) THEN CALL OTTOIN(ISING,IFERM,IBRUP,LEBIL,PENTE,PENTE2, & NCA,NN,MC,MM,STOT,DSIGT,DDE,GS,FC, & XINVL,SMAX,XLTR,PRECIZ,XCOMP,XLAMC,KERRE) IF(KERRE.NE.0) RETURN * write (6,*) ' pente apres ottoin dans ottoca ',(PENTE(IC),IC=1,4) ENDIF * 444 CONTINUE * IF(ITER.NE.0) THEN * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,74078) 74078 FORMAT(/2X,' ON REINITIALISE LE PROCESSUS'//) ENDIF * DO I=1,6 DEPSTT(I)=DEPST0(I) STOT(I)=SIG0(I) ENDDO CALL ZDANUL(DEFPLA,6) CALL ZDANUL(VAUX,6) CALL ZDANUL(VAUX1,6) CALL ZDANUL(VAUX2,6) * DO I=1,3 IF (XINVL(I).NE.XZER) THEN W(I)=W0(I) WMAX(I)=WMAX0(I) WREOUV(I) = BTR*MIN(WMAX(I),WRUPT(I)) SMAX(I)=SMAX0(I) ENDIF ENDDO XLAMC=XLAMC0 * ******* ******* REACTUALISATION DE DDE ? ******* CALL OTTODD(DDE,YOUN,XNU,G,GS,XINVL,W) ******* * * write (6,*) ' pente avant ottocr dans ottoca ',(PENTE(IC),IC=1,4) CALL OTTOCR(NCA,NN,STOT,W,WMAX,SMAX,BILIN,WRUPT,BTR, & XLTR,XINVL,SBILI,FC,PENTE,LEBIL, & PRECIE,PRECIZ,XCOMP,XLAMC,KERRE) IF(KERRE.NE.0) RETURN * write (6,*) ' pente avant ottocr dans ottoca ',(PENTE(IC),IC=1,4) * ENDIF * XX=0.D0 DO IC=1,NC+1 DX(IC)=0.D0 DDX(IC)=0.D0 ENDDO * * MLR 9/7/99 * RETRAITEMENT DE MM SI ICOMPL=1 * ICOMPL=0 DO IJ=1,NCA IF(NN(IJ).EQ.4.AND.ICOCRI.EQ.1) ICOMPL=1 ENDDO * MC2=0 DO I=1,MC IF(ICOMPL.EQ.1.AND.MM(I).EQ.16) GO TO 102 * MC2=MC2+1 MM2(MC2)=MM(I) 102 CONTINUE ENDDO * * * ------------------------------- * | LES ITERATIONS INTERNES | * ------------------------------- 555 CONTINUE ITER=ITER+1 IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77888) ITER 77888 FORMAT(1X,' >>>>>>>>>>> OTTOCA - ITER =',I4/) ENDIF * IF(ITER.GT.ITMAX) THEN KERRE=2 RETURN ENDIF * CALL SHIFTD(STOT,SIGEL,6) CALL ZDANUL(DDPLAS,6) IF(IIMPI.EQ.42) THEN WRITE(IOIMP,60081) (SIGEL(I),I=1,6) 60081 FORMAT(1X,' SIGEL '/(6(1X,1PE12.5))/) ENDIF * * write (6,*) ' pente avant ottofl dans ottoca ',(PENTE(IC),IC=1,4) CALL OTTOFL(NCA,NN,XINVL,PENTE,SIGEL,GS,SMAX,XLTR, & DFDS,DGDS,HDFDQ,XCOMP,XLAMC,PRECIE, & PRECIZ,KERRE) IF(KERRE.NE.0) RETURN * write (6,*) ' pente avant ottofl dans ottoca ',(PENTE(IC),IC=1,4) * * * * REMPLISSAGES * NDIM=NCA IF(IFOUR.EQ.-2) NDIM=NCA+1 * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77010) NCA,NDIM 77010 FORMAT(5X,'NCA=',I3,2X,'NDIM =',I3/) WRITE(IOIMP,77018) (NN(IJ),IJ=1,NCA) 77018 FORMAT(5X,'NN ',5(1X,I3)) ENDIF * DO IJ=1,NCA * JJ=NN(IJ) CALL OTTOPR(DDE,DGDS(1,JJ),VAUX1) * DO IK=1,NCA JK=NN(IK) AA(IK,IJ)= DDOT(6,DFDS(1,JK),1,VAUX1,1) IF(IK.EQ.IJ) AA(IK,IJ)=AA(IK,IJ)-HDFDQ(JK) ENDDO BB1(IJ)=FC(JJ) BB2(IJ)=DDOT(6,DFDS(1,JJ),1,DSIGT,1) * * SPECIAL CP * IF(IFOUR.EQ.-2) THEN * LA COMPOSANTE EPS 33 EST EN POSITION 1 ( CF RAPPEL ) AA(IJ,NDIM)=-(DFDS(1,JJ)*DDE(1)+DFDS(2,JJ)*DDE(6) * +DFDS(3,JJ)*DDE(5)+DFDS(4,JJ)*DDE(10)) AA(NDIM,IJ)=VAUX1(1) ENDIF ENDDO * DO IK=1,NCA IF(AA(IK,IK).LT.0.D0) THEN PRINT *,' OTTOCA - TERME DIAGONAL NEGATIF' KERRE=61 WRITE(IOIMP,77011) ((AA(I,J),J=1,5),I=1,5) RETURN ENDIF ENDDO * IF(IFOUR.EQ.-2) THEN AA(NDIM,NDIM)=-DDE(1) BB1(NDIM)=SIGEL(1) BB2(NDIM)=DSIGT(1) ENDIF * * SPECIAL XX(N+1) * DO I=1,NDIM BB1(I)=BB1(I) - XX*BB2(I) ENDDO * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77011) ((AA(I,J),J=1,5),I=1,5) 77011 FORMAT(5X,' MATRICE AA'/(5(1X,1PE12.5))) WRITE(IOIMP,77012) (BB1(I),I=1,5) 77012 FORMAT(5X,' VECTEUR BB1'/(5(1X,1PE12.5))) WRITE(IOIMP,70012) (BB2(I),I=1,5) 70012 FORMAT(5X,' VECTEUR BB2'/(5(1X,1PE12.5))) ENDIF * * RESOLUTION * KERRE=0 CALL INVALM(AA,NC1,NDIM,KERRE,1D-10) IF(KERRE.NE.0) THEN RETURN ENDIF IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77013) ((AA(I,J),J=1,5),I=1,5) 77013 FORMAT(5X,' MATRICE AA INVERSEE '/(5(1X,1PE12.5))) ENDIF * CALL MULMA2(VEC1,AA,BB1,NDIM,1,NDIM,NC1,NC1) CALL MULMA2(VEC2,AA,BB2,NDIM,1,NDIM,NC1,NC1) * CALL ZDANUL(VAUX1,6) CALL ZDANUL(VAUX2,6) * DO IJ=1,NCA JJ=NN(IJ) DO I=1,6 VAUX1(I)=VAUX1(I)+DGDS(I,JJ)*VEC1(IJ) VAUX2(I)=VAUX2(I)+DGDS(I,JJ)*VEC2(IJ) ENDDO IF(JJ.LE.3) THEN DXV1(JJ)=VEC1(IJ) DXV2(JJ)=VEC2(IJ) ENDIF ENDDO * IF(IFOUR.EQ.-2) THEN VAUX1(1)=VAUX1(1)-VEC1(NDIM) VAUX2(1)=VAUX2(1)-VEC2(NDIM) ENDIF * CALL OTTOPR(DDE,VAUX1,SIG1) CALL OTTOPR(DDE,VAUX2,SIG2) IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77081) (SIG1(I),I=1,6) 77081 FORMAT(5X,' VECTEUR SIG1'/(6(1X,1PE12.5))) WRITE(IOIMP,70082) (SIG2(I),I=1,6) 70082 FORMAT(5X,' VECTEUR SIG2'/(6(1X,1PE12.5))) ENDIF DO I=1,6 SIG1(I)=SIGEL(I)-SIG1(I)-XX*DSIGT(I) SIG2(I)=DSIGT(I) - SIG2(I) ENDDO * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,73312) (VEC1(I),I=1,5) 73312 FORMAT(5X,' VECTEUR VEC1'/(5(1X,1PE12.5))) WRITE(IOIMP,73313) (VEC2(I),I=1,5) 73313 FORMAT(5X,' VECTEUR VEC2'/(5(1X,1PE12.5))) WRITE(IOIMP,74412) (VAUX1(I),I=1,6) 74412 FORMAT(5X,' VECTEUR VAUX1'/(6(1X,1PE12.5))) WRITE(IOIMP,74413) (VAUX2(I),I=1,6) 74413 FORMAT(5X,' VECTEUR VAUX2'/(6(1X,1PE12.5))) WRITE(IOIMP,77014) (SIG1(I),I=1,6) 77014 FORMAT(5X,' VECTEUR SIG1'/(6(1X,1PE12.5))) WRITE(IOIMP,70014) (SIG2(I),I=1,6) 70014 FORMAT(5X,' VECTEUR SIG2'/(6(1X,1PE12.5))) ENDIF * * ICOMEL=0 CALL OTTOCE(MC2,MM2,SIG1,DX,DXV1,W,WMAX,SMAX,WRUPT, & XLTR,XINVL,BTR,NFISSU,NVF,FCV1,VF,YOUN, & PRECIZ,JFIS,XCOMP,XLAMC,DFF,DGG,KERRE) IF(KERRE.NE.0) RETURN * * MLR 9/7/99 * IF(ICOCRI.EQ.1.AND.ICOMPL.EQ.0.AND. & ABS(FCV1(16)).LE.PRECIZ) THEN ICOMEL=1 ENDIF * CALL OTTOXX(MC2,MM2,SIG1,SIG2,STOT, & VAUX1,VAUX2,VAUX,FCV1,DX,DXV1,DXV2, & PRECIE,PRECIZ,BTR,YOUN, & W,WMAX,SMAX,WRUPT,XLTR,XINVL,NFISSU,NVF,VF, & XXX,IRESU,NRESU,XCOMP,XLAMC,ICOMEL,LERED,KERRE) * IF(KERRE.NE.0) RETURN IF(LERED.EQ.1) GO TO 888 * DO IJ=1,NCA DDX(IJ)=VEC1(IJ)+XXX*VEC2(IJ) ENDDO * * TESTS * IF(XXX.LE.0.D0) THEN KERRE=2 PRINT *,' XXX EST NEGATIF OU NUL ' RETURN ENDIF * * NCAA=0 DO IJ=1,NCA JJ=NN(IJ) DXSOM=DX(JJ)+DDX(IJ) * IF(DXSOM.GE.0.D0) THEN NCAA=NCAA+1 NN(NCAA)=JJ ELSE IF(DXSOM.LT.0.D0) THEN IF(LEBIL(JJ).EQ.1) THEN IF(IFERM(JJ).NE.1) THEN NCAA=NCAA+1 NN(NCAA)=JJ * ELSE IF(IFERM(JJ).EQ.1) THEN IF(W0(JJ)+DXSOM/XINVL(JJ).GT.WREOUV(JJ)) THEN NCAA=NCAA+1 NN(NCAA)=JJ ENDIF ENDIF * ENDIF ENDIF ENDDO * * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77008) NCA,NCAA,(NN(IJ),IJ=1,NCAA) 77008 FORMAT(5X,'NCA=',I3,2X,'NCAA=',I3/2X,'NN ' ,8I3/) WRITE(IOIMP,77607) (DDX(IJ),IJ=1,NC+1) 77607 FORMAT(5X,'DDX '/(8(1X,1PE12.5))/) ENDIF * * QUELQUES TESTS SUPPLEMENTAIRES * IF(NCAA.EQ.0) THEN IF(IIMPI.EQ.42) THEN PRINT *,' OTTOCA - NCAA EST NUL ' ENDIF GO TO 888 ENDIF * * IF(NCA.NE.NCAA) THEN * IF(NCAA.GT.NCA) THEN KERRE=7 PRINT *,' OTTOCA - NCAA EST SUPERIEUR A NCA ' RETURN ENDIF NCA=NCAA GO TO 444 ENDIF * * ON ENQUILLE * XX=XXX DO IJ=1,NCA JJ=NN(IJ) DX(JJ)=DX(JJ)+DDX(IJ) DO I=1,6 DDPLAS(I)=DDPLAS(I)+DGDS(I,JJ)*DDX(IJ) DEFPLA(I)=DEFPLA(I)+DGDS(I,JJ)*DDX(IJ) ENDDO * IF(JJ.EQ.4) THEN XLAMC=XLAMC0+DX(4) ENDIF ENDDO * DO I=1,3 IF (XINVL(I).NE.XZER) W(I)=W0(I)+DX(I)/XINVL(I) IF (W(I).GT.WMAX0(I)) THEN IF(LEBIL(I).NE.1.OR.WMAX0(I).GE.WRUPT(I)) THEN WMAX(I)=W(I) WREOUV(I) = BTR*MIN(WMAX(I),WRUPT(I)) ENDIF ENDIF ENDDO * IF(IFOUR.EQ.-2) THEN DEPSTT(1)=DEPSTT(1)+DDX(NDIM) STOT(1)=STOT(1)-DDE(1)*DDX(NDIM) STOT(2)=STOT(2)-DDE(6)*DDX(NDIM) STOT(3)=STOT(3)-DDE(5)*DDX(NDIM) STOT(4)=STOT(4)-DDE(10)*DDX(NDIM) ENDIF * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77991) (DEFPLA(IJ),IJ=1,6) 77991 FORMAT(1X,' DEFPLA '/(6(1X,1PE12.5))/) WRITE(IOIMP,60091) (DDPLAS(IJ),IJ=1,6) 60091 FORMAT(1X,' DDPLAS '/(6(1X,1PE12.5))/) WRITE(IOIMP,60095) (DX(IJ),IJ=1,NC+1) 60095 FORMAT(1X,' DX '/(6(1X,1PE12.5))/) WRITE(IOIMP,60096) XLAMC 60096 FORMAT(1X,' XLAMC=',1PE12.5/) WRITE(IOIMP,60901) (W0(IJ),IJ=1,3) 60901 FORMAT(1X,' W0 '/(3(1X,1PE12.5))/) WRITE(IOIMP,70901) (W(IJ),IJ=1,3),(WMAX(IJ),IJ=1,3) 70901 FORMAT(1X,' W '/(3(1X,1PE12.5))/ & 1X,' WMAX '/(3(1X,1PE12.5))/) WRITE(IOIMP,70091) (STOT(IJ),IJ=1,6) 70091 FORMAT(1X,' ENFIN STOT '/(6(1X,1PE12.5))/) WRITE(IOIMP,70080) 70080 FORMAT(1X,' FIN DE L ITERATION - AVANT TESTS ' /) WRITE(IOIMP,77806) (STOT(I),I=1,6) 77806 FORMAT(1X,' STOT ' /(6(1X,1PE12.5))/) ENDIF * * TESTS DE CONVERGENCE * * write (6,*) ' pente avant ottocr dans ottoca ',(PENTE(IC),IC=1,4) CALL OTTOCR(NCA,NN,STOT,W,WMAX,SMAX,BILIN,WRUPT,BTR, & XLTR,XINVL,SBILI,FC,PENTE,LEBIL, & PRECIE,PRECIZ,XCOMP,XLAMC,KERRE) IF(KERRE.NE.0) RETURN * write (6,*) ' pente apres ottocr dans ottoca ',(PENTE(IC),IC=1,4) * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77903) (LEBIL(IJ),IJ=1,NC) 77903 FORMAT(1X,' TESTS DE CONVERGENCE - SORTIE DE OTTOCR '/ & 2X,' LEBIL ' , (4(1X,I4))/) WRITE(IOIMP,77093) (FC(IJ),IJ=1,NC) 77093 FORMAT(1X,' FC ',(4(1X,1PE12.5))/) ENDIF * DO IJ=1,NCA JJ=NN(IJ) IF (ABS(FC(JJ)).GT.PRECIZ) GO TO 555 ENDDO IF(IFOUR.EQ.-2) THEN IF(ABS(STOT(1)).GT.PRECIZ) GO TO 555 ENDIF * * MISE A JOUR DE WMAX ET SMAX * DO I=1,3 IF(W(I).GT.WMAX(I)) THEN WMAX(I)=W(I) * write (6,*) ' pente avant ottofu dans ottoca ',(PENTE(IC),IC=1,4) CALL OTTOFU(XINVL,XLTR,WRUPT,BTR,BILIN, & SBILI,W,WMAX,SMAX,PENTE,I) * write (6,*) ' pente apres ottofu dans ottoca ',(PENTE(IC),IC=1,4) ENDIF ENDDO * * 89 CONTINUE * * * ENCORE QUELQUES TESTS * CALL OTTOVE(NRESU,IRESU,STOT,W,WMAX,WRUPT,SMAX, & BTR,XLTR,XINVL,BILIN,SBILI,PRECIE,PRECIZ,DEFPLA, & NN,NC,NCA,FC,FC2,PENTE,PENTE2,LEBIL,ISING, & XCOMP,XLAMC,KERRE) IF(KERRE.NE.0) RETURN * * SORTIE - REMPLISSAGE * DO I=1,6 SIGF(I)=STOT(I) DEFP(I)=DEFPLA(I) ENDDO * XX=XX*REFAC * * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77895) (SIGF(IJ),IJ=1,6) 77895 FORMAT(1X,' OTTOCA - SIGF '/(6(1X,1PE12.5))/) WRITE(IOIMP,77896) (DEFP(IJ),IJ=1,6) 77896 FORMAT(1X,' OTTOCA - DEFP '/(6(1X,1PE12.5))/) ENDIF * RETURN END