C OTTOIN SOURCE KK2000 05/06/23 21:15:02 5122 SUBROUTINE OTTOIN(ISING,IFERM,IBRUP,LEBIL,PENTE,PENTE2, & NCA,NN,MC,MM,SIGEL,DSIGT,DDE,GS,FC, & XINVL,SMAX,XLTR,PRECIZ,XCOMP, & XLAMC,KERRE) C---------------------------------------------------------------------- C C ENTREES : SIG0,DEPST,PRECIZ,MFR,KERRE C C SORTIES : SIGF C C----------------------------------------------------------------------- C IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) -INC CCOPTIO * PARAMETER (XZER=0.D0,NC=6) DIMENSION SIGEL(*),DSIGT(*),DDE(*),XLTR(*),XCOMP(*) DIMENSION DSIG(6) ,DSIGP(6) DIMENSION SAUX(6),DDPLAS(6) * DIMENSION GS(3) DIMENSION XINVL(3),NSITUA(4) * DIMENSION DFF(6),DGG(6) * DIMENSION SMAX(*),ISING(*),IFERM(*),IBRUP(*) DIMENSION JESEC(4) * *ZZZZZZ ??? TAILLES A AJUSTER ? DIMENSION FC(NC),NN(NC),PENTE(NC),LEBIL(NC),NN2(NC) DIMENSION MM(*) DIMENSION LEBIL2(NC),PENTE2(NC),PENT(NC) DIMENSION AA(NC+1,NC+1),BB1(NC+1),BB2(NC+1) DIMENSION DX(NC+1),DDX(NC+1) DIMENSION VEC1(NC+1),VEC2(NC+1) DIMENSION DFDS(6,NC),DGDS(6,NC),HDFDQ(NC) DIMENSION LASIT(NC) DIMENSION VAUX1(6) * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,74411) (ISING(IC),IC=1,NC), & (IFERM(IC),IC=1,NC), & (IBRUP(IC),IC=1,NC) 74411 FORMAT(5X,' ENTREE DANS OTTOIN - ISING = ',4I3, & 2X,'IFERM = ',4I3/2X,'IBRUP = ',4I3/) ENDIF * IF(IFERM(4).EQ.1.AND.ABS(FC(4)).GT.PRECIZ) THEN PRINT *,'OTTOIN - INCOHERENCE EN COMPRESSION ' KERRE=2 RETURN ENDIF * * INITIALISATIONS * NC1=NC+1 KERRE=0 CALL SHIFTD(PENTE,PENT,6) PRECIE=1.D-10 * * DO IC=1,4 NSITUA(IC)=1 + ISING(IC) + IFERM(IC) + IBRUP(IC) * IF(NSITUA(IC).GT.2) THEN WRITE(IOIMP,74412) IC,ISING(IC),IFERM(IC),IBRUP(IC) 74412 FORMAT(2X,'####### CAS IMPOSSIBLE IC=',I3,2X, & 'ISING(IC)=',I3,2X,'IFERM(IC)=',I3,2X, & 'IBRUP(IC)=',I3/) KERRE=7 RETURN ENDIF ENDDO * DO 21 I1=1,NSITUA(1) LASIT(1)=I1 * DO 22 I2=1,NSITUA(2) LASIT(2)=I2 * DO 23 I3=1,NSITUA(3) LASIT(3)=I3 * DO 24 I4=1,NSITUA(4) LASIT(4)=I4 * * TYPES 1 (ISING) ( IC=1 A 3 ) * 1 : PENTE2 (SECANTE) * 2 : PENTE * * TYPES 2 (IFERM) ( IC=1 A 4 ) * 1 : ELASTIQUE * 2 : PENTE SECANTE * * TYPES 3 (IBRUP) ( IC=1 A 3 ) * 1 : ELASTIQUE * 2 : PENTE * DO IC=1,3 IF(LASIT(IC).EQ.2) THEN PENT(IC)=PENTE(IC) ELSE IF(LASIT(IC).EQ.1.AND.ISING(IC).EQ.1) THEN PENT(IC)=PENTE2(IC) ENDIF ENDDO * * CALL IANUL(JESEC,4) NCA2=0 DO IJ=1,NCA JJ=NN(IJ) IF(LASIT(JJ).EQ.1) THEN IF(IFERM(JJ).NE.1.AND.IBRUP(JJ).NE.1) THEN NCA2=NCA2+1 NN2(NCA2)=JJ ENDIF * ELSE IF(LASIT(JJ).EQ.2) THEN NCA2=NCA2+1 NN2(NCA2)=JJ IF(IFERM(JJ).EQ.1.AND.JJ.LE.3) THEN JESEC(JJ)=1 ENDIF ENDIF * ENDDO * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,60080) I1,I2,I3,I4,NCA,NCA2 60080 FORMAT(//2X,' ******** SITUATION : I1 I2 I3 I4 ', & 4I3/2X,'NCA=',I3,2X,'NCA2=',I3/) ENDIF * IF(NCA2.EQ.0) THEN GO TO 55 ENDIF * * INITIALISATIONS * CALL ZDANUL(VAUX1,6) CALL ZDANUL(DDPLAS,6) IF(IIMPI.EQ.42) THEN WRITE(IOIMP,60081) (SIGEL(I),I=1,6) 60081 FORMAT(2X,' SIGEL '/(6(1X,1PE12.5))/) ENDIF * * CALL OTTOFL(NCA2,NN2,XINVL,PENT,SIGEL,GS,SMAX,XLTR, & DFDS,DGDS,HDFDQ,XCOMP,XLAMC,PRECIE, & PRECIZ,KERRE) IF(KERRE.NE.0) RETURN * * NDIM=NCA2 IF(IFOUR.EQ.-2) NDIM=NCA2+1 * IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77010) NCA2,NDIM 77010 FORMAT(5X,'NCA2=',I3,2X,'NDIM =',I3/) WRITE(IOIMP,77018) (NN2(IJ),IJ=1,NCA2) 77018 FORMAT(5X,'NN2 ',5(1X,I3)) ENDIF * DO IJ=1,NCA2 * JJ=NN2(IJ) CALL OTTOPR(DDE,DGDS(1,JJ),VAUX1) * DO IK=1,NCA2 JK=NN2(IK) AA(IK,IJ)= SDOT(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)=SDOT(6,DFDS(1,JJ),1,DSIGT,1) * * SPECIAL CP * IF(IFOUR.EQ.-2) THEN 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 * IF(IFOUR.EQ.-2) THEN AA(NDIM,NDIM)=-DDE(1) BB1(NDIM)=SIGEL(1) BB2(NDIM)=DSIGT(1) ENDIF * * 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 * * KERRE=0 CALL INVALM(AA,NC1,NDIM,KERRE,PRECIZ) IF(KERRE.NE.0) THEN PRINT *,' MATRICE SINGULIERE DANS OTTOIN ' RETURN ENDIF * IF(IIMPI.EQ.42) THEN * WRITE(IOIMP,77113) ((AA(I,J),J=1,5),I=1,5) *77113 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) * DO IJ=1,NDIM DDX(IJ)=VEC1(IJ)+VEC2(IJ) ENDDO IF(IIMPI.EQ.42) THEN WRITE(IOIMP,77013) (DDX(IJ),IJ=1,NDIM) 77013 FORMAT(5X,' OTTOIN - DDX CALCULE'/(5(1X,1PE12.5))) ENDIF * * DO IJ=1,NCA2 JJ=NN2(IJ) DO I=1,6 DDPLAS(I)=DDPLAS(I)+DGDS(I,JJ)*DDX(IJ) ENDDO ENDDO * CALL OTTOPR(DDE,DDPLAS,DSIGP) * IF(IFOUR.EQ.-2) THEN DSIGP(1)=DSIGP(1)-DDE(1)*DDX(NDIM) DSIGP(2)=DSIGP(2)-DDE(6)*DDX(NDIM) DSIGP(3)=DSIGP(3)-DDE(5)*DDX(NDIM) DSIGP(4)=DSIGP(4)-DDE(10)*DDX(NDIM) ENDIF * DO I=1,6 DSIG(I)=DSIGT(I)-DSIGP(I) ENDDO IF(IIMPI.EQ.42) THEN WRITE(IOIMP,79013) (DSIG(I),I=1,6) 79013 FORMAT(5X,' DSIG CALCULE '/(6(1X,1PE12.5))) ENDIF * * IFLAG=0 DO IJ=1,NCA2 JJ=NN2(IJ) IF(ISING(JJ).EQ.1) THEN IF(DSIG(JJ).GT.PRECIZ) IFLAG=1 IF(PENT(JJ).EQ.PENTE(JJ).AND.DDX(IJ).LT.0.D0) IFLAG=1 IF(PENT(JJ).EQ.PENTE2(JJ).AND.DDX(IJ).GT.0.D0) IFLAG=1 ENDIF * IF(IFERM(JJ).EQ.1) THEN IF(DDX(IJ).LT.0.D0.OR.DSIG(JJ).LT.-PRECIZ) IFLAG=1 ENDIF ENDDO * DO I=1,3 IF(IFERM(I).EQ.1.AND.LASIT(I).EQ.1) THEN IF(DSIG(I).GT.PRECIZ) IFLAG=1 ENDIF ENDDO * DO I=1,3 IF(IBRUP(I).EQ.1.AND.LASIT(I).EQ.1) THEN IF(DSIG(I).GT.PRECIZ) IFLAG=1 ENDIF ENDDO * * MLR 9/7/99 * DO IJ=1,NCA JJ=NN(IJ) IF(JJ.EQ.4.AND.LASIT(4).EQ.1) THEN CALL OTTOCP(SIGEL,FCR4,XLTR,DFF,DGG,H4, & PRECIE,PRECIZ,XCOMP,XLAMC,KERRE) * TRA = 0.D0 DO I=1,6 TRA = TRA + DFF(I)*DSIG(I) ENDDO IF(IIMPI.EQ.42) THEN WRITE(IOIMP,76621) TRA 76621 FORMAT(///2X,'OTTOIN ****** TRA = ',1PE12.5//) ENDIF IF(TRA.GT.PRECIZ) IFLAG=1 ENDIF ENDDO * * IF(IFLAG.EQ.0) THEN DO IJ=1,NCA2 JJ=NN2(IJ) IF(ISING(JJ).EQ.1) THEN IF(PENT(JJ).EQ.PENTE(JJ)) THEN ISING(JJ)=2 LEBIL(JJ)=0 ENDIF IF(PENT(JJ).EQ.PENTE2(JJ)) THEN ISING(JJ)=3 LEBIL(JJ)=1 ENDIF ENDIF ENDDO GO TO 99 ENDIF * 55 CONTINUE * 24 CONTINUE * 23 CONTINUE * 22 CONTINUE * 21 CONTINUE * * EN CAS DE PROBLEME : * KERRE=7 * VALEUR DE KERRE A AMELIORER * WRITE(IOIMP,73312) 73312 FORMAT(2X,'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ' / & 4X,'ATTENTION - OTTOIN - PAS DE SOLUTION ' / & 2X,'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ'/) RETURN * 99 CONTINUE * CALL SHIFTD(PENT,PENTE,6) IF(IIMPI.EQ.42) THEN WRITE(IOIMP,70801) (PENTE(I),I=1,NC) 70801 FORMAT(///2X,'OTTOIN SORTIE - PENTE '/(4(1X,1PE12.5)/)) WRITE(IOIMP,76802) (LEBIL(I),I=1,NC) 76802 FORMAT(/2X,'OTTOIN SORTIE - LEBIL '/(4I5/)) WRITE(IOIMP,76803) (ISING(I),I=1,NC) 76803 FORMAT(/2X,'OTTOIN SORTIE - ISING '/(4I5/)) ENDIF * * RETRAITEMENT * NCA=NCA2 DO I=1,NCA NN(I)=NN2(I) ENDDO * MC2=0 DO I=1,MC * * TYPES 1 * IF(MM(I).GE.7.AND.MM(I).LE.9) THEN IC=MM(I)-6 IF(ISING(IC).EQ.3) GO TO 101 ENDIF IF(MM(I).GE.13.AND.MM(I).LE.15) THEN IC=MM(I)-12 IF(ISING(IC).EQ.2) GO TO 101 ENDIF * * TYPES 2 * IF(MM(I).GE.4.AND.MM(I).LE.6) THEN IC=MM(I)-3 IF(IFERM(IC).EQ.1.AND.JESEC(IC).EQ.0) GO TO 101 ENDIF * MC2=MC2+1 MM(MC2)=MM(I) 101 CONTINUE ENDDO MC=MC2 IF(IIMPI.EQ.42) THEN WRITE(IOIMP,44102) NCA 44102 FORMAT(2X,'OTTOIN - NOUVELLE VALEUR NCA =',I3/) WRITE(IOIMP,44103) (NN(IC),IC=1,NCA) 44103 FORMAT(2X,'OTTOIN - NOUVELLE LISTE NN '/16(1X,I3)/) WRITE(IOIMP,49102) MC 49102 FORMAT(2X,'OTTOIN - NOUVELLE VALEUR MC =',I3/) WRITE(IOIMP,49103) (MM(IC),IC=1,MC) 49103 FORMAT(2X,'OTTOIN - NOUVELLE LISTE MM '/16(1X,I3)/) ENDIF RETURN END