Télécharger la plaquette Cast3M


fr en

Télécharger ottoin.eso

Retour à la liste

Numérotation des lignes : 

ottoin

  1. C OTTOIN    SOURCE    FANDEUR   22/05/02    21:15:27     11359          
  2.       SUBROUTINE OTTOIN(ISING,IFERM,IBRUP,LEBIL,PENTE,PENTE2,
  3.      &                  NCA,NN,MC,MM,SIGEL,DSIGT,DDE,GS,FC,
  4.      &                  XINVL,SMAX,XLTR,PRECIZ,XCOMP,
  5.      &                  XLAMC,KERRE)
  6. C----------------------------------------------------------------------
  7. C
  8. C  ENTREES   :  SIG0,DEPST,PRECIZ,MFR,KERRE
  9. C
  10. C  SORTIES   :  SIGF
  11. C
  12. C-----------------------------------------------------------------------
  13. C
  14.       IMPLICIT INTEGER(I-N)
  15.       IMPLICIT REAL*8(A-H,O-Z)
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. *
  20.       PARAMETER (XZER=0.D0,NC=4)
  21.  
  22.       DIMENSION SIGEL(*),DSIGT(*),DDE(*),XLTR(*),XCOMP(*)
  23.       DIMENSION SMAX(*),ISING(*),IFERM(*),IBRUP(*)
  24.       DIMENSION FC(*),NN(*),PENTE(*),LEBIL(*),PENTE2(*)
  25.       DIMENSION MM(*)
  26.       DIMENSION DSIG(6) ,DSIGP(6)
  27.       DIMENSION SAUX(6),DDPLAS(6)
  28. *
  29.       DIMENSION GS(3)
  30.       DIMENSION XINVL(3),NSITUA(4)
  31. *
  32.       DIMENSION DFF(6),DGG(6)
  33. *
  34.       DIMENSION JESEC(4)
  35. *
  36.       DIMENSION LEBIL2(6),PENT(6),NN2(NC)
  37.       DIMENSION AA(NC+1,NC+1),BB1(NC+1),BB2(NC+1)
  38.       DIMENSION DX(NC+1),DDX(NC+1)
  39.       DIMENSION VEC1(NC+1),VEC2(NC+1)
  40.       DIMENSION DFDS(6,NC),DGDS(6,NC),HDFDQ(NC)
  41.       DIMENSION LASIT(NC)
  42.       DIMENSION VAUX1(6)
  43.  
  44.       REAL*8   DDOT
  45.       EXTERNAL DDOT
  46.  
  47.       IF(IIMPI.EQ.42) THEN
  48.          WRITE(IOIMP,74011) (ISING(IC),IC=1,NC)
  49.          WRITE(IOIMP,74111) (IFERM(IC),IC=1,NC)
  50.          WRITE(IOIMP,74211) (IBRUP(IC),IC=1,NC)
  51.          WRITE(IOIMP,74311) (NN(IC),IC=1,NCA)
  52. 74011    FORMAT(5X,' ENTREE DANS OTTOIN - ISING = ',4I3/)
  53. 74111    FORMAT(5X,' ENTREE DANS OTTOIN - IFERM = ',4I3/)
  54. 74211    FORMAT(5X,' ENTREE DANS OTTOIN - IBRUP = ',4I3/)
  55. 74311    FORMAT(//5X,' ENTREE DANS OTTOIN - NN = ',4I3/)
  56.       ENDIF
  57. *
  58.       IF(IFERM(4).EQ.1.AND.ABS(FC(4)).GT.PRECIZ) THEN
  59.         PRINT *,'OTTOIN - INCOHERENCE EN COMPRESSION '
  60.         KERRE=2
  61.         RETURN
  62.       ENDIF
  63. *
  64. *   INITIALISATIONS
  65. *
  66.       NC1=NC+1
  67.       KERRE=0
  68.       CALL SHIFTD(PENTE,PENT,6)
  69.       PRECIE=1.D-10
  70. *
  71. *
  72.       DO IC=1,4
  73.          NSITUA(IC)=1 + ISING(IC) + IFERM(IC) + IBRUP(IC)
  74.  
  75.             IF(IIMPI.EQ.42) THEN
  76.                WRITE(IOIMP,69980) IC,NSITUA(IC)
  77. 69980          FORMAT(//2X,'   IC= ',I4,2X,' NSITUA= ',I4//)
  78.             ENDIF
  79.  
  80.  
  81. *
  82.          IF(NSITUA(IC).GT.2) THEN
  83.             WRITE(IOIMP,74412) IC,ISING(IC),IFERM(IC),IBRUP(IC)
  84. 74412       FORMAT(2X,'#######  CAS IMPOSSIBLE IC=',I3,2X,
  85.      &             'ISING(IC)=',I3,2X,'IFERM(IC)=',I3,2X,
  86.      &             'IBRUP(IC)=',I3/)
  87.             KERRE=7
  88.             RETURN
  89.          ENDIF
  90.       ENDDO
  91.  
  92. *
  93.       DO 21 I1=1,NSITUA(1)
  94.         LASIT(1)=I1
  95. *
  96.         DO 22 I2=1,NSITUA(2)
  97.           LASIT(2)=I2
  98. *
  99.           DO 23 I3=1,NSITUA(3)
  100.             LASIT(3)=I3
  101. *
  102.             DO 24 I4=1,NSITUA(4)
  103.               LASIT(4)=I4
  104. *
  105. *           TYPES 1  (ISING)  ( IC=1 A 3 )
  106. *                 1  : PENTE2  (SECANTE)
  107. *                 2  : PENTE
  108. *
  109. *           TYPES 2  (IFERM)  ( IC=1 A 4 )
  110. *                 1  : ELASTIQUE
  111. *                 2  : PENTE SECANTE
  112. *
  113. *           TYPES 3  (IBRUP)  ( IC=1 A 3 )
  114. *                 1  : ELASTIQUE
  115. *                 2  : PENTE
  116. *
  117.                DO IC=1,3
  118.                   IF(LASIT(IC).EQ.2) THEN
  119.                      PENT(IC)=PENTE(IC)
  120.                   ELSE IF(LASIT(IC).EQ.1.AND.ISING(IC).EQ.1) THEN
  121.                      PENT(IC)=PENTE2(IC)
  122.                   ENDIF
  123.                ENDDO
  124.  
  125.             IF(IIMPI.EQ.42) THEN
  126.                WRITE(IOIMP,60080) I1,I2,I3,I4
  127. 60080          FORMAT(//2X,' ********  SITUATION : I1 I2 I3 I4 ',
  128.      &                  4I3///)
  129.             ENDIF
  130.  
  131.  
  132.             IF(IIMPI.EQ.42) THEN
  133.                WRITE(IOIMP,10080) (PENTE(IC),IC=1,3)
  134. 10080          FORMAT(/2X,' PENTE ',3(2X,1PE12.5)/)
  135.                WRITE(IOIMP,10081) (PENTE2(IC),IC=1,3)
  136. 10081          FORMAT(/2X,' PENTE2 ',3(2X,1PE12.5)/)
  137.                WRITE(IOIMP,10082) (PENT(IC),IC=1,3)
  138. 10082          FORMAT(/2X,' PENT ',3(2X,1PE12.5)/)
  139.             ENDIF
  140.  
  141. *
  142. *
  143.             CALL IANUL(JESEC,4)
  144.             NCA2=0
  145.             DO IJ=1,NCA
  146.                JJ=NN(IJ)
  147.  
  148.             IF(IIMPI.EQ.42) THEN
  149.                WRITE(IOIMP,20080) JJ,LASIT(JJ),IFERM(JJ),IBRUP(JJ)
  150. 20080          FORMAT(/2X,'JJ=',I3,2X, 'LASIT=',I3,2X,
  151.      &                    'IFERM=',I3,2X,'IBRUP=',I3//)
  152.             ENDIF
  153.  
  154.  
  155.  
  156.                IF(LASIT(JJ).EQ.1) THEN
  157.                   IF(IFERM(JJ).NE.1.AND.IBRUP(JJ).NE.1) THEN
  158.                      NCA2=NCA2+1
  159.                      NN2(NCA2)=JJ
  160.                   ENDIF
  161. *
  162.                ELSE IF(LASIT(JJ).EQ.2) THEN
  163.                   NCA2=NCA2+1
  164.                   NN2(NCA2)=JJ
  165.                   IF(IFERM(JJ).EQ.1.AND.JJ.LE.3) THEN
  166.                      JESEC(JJ)=1
  167.                   ENDIF
  168.                ENDIF
  169. *
  170.             ENDDO
  171.  
  172.             IF(IIMPI.EQ.42) THEN
  173.                WRITE(IOIMP,60086) NCA,NCA2
  174. 60086          FORMAT(//
  175.      &                  2X,'NCA=',I3,2X,'NCA2=',I3/)
  176.             ENDIF
  177. *
  178. *
  179.             IF(NCA2.EQ.0) THEN
  180.                GO TO 55
  181.             ENDIF
  182. *
  183. *           INITIALISATIONS
  184. *
  185.             CALL ZDANUL(VAUX1,6)
  186.             CALL ZDANUL(DDPLAS,6)
  187.  
  188.  
  189.             IF(IIMPI.EQ.42) THEN
  190.                WRITE(IOIMP,60081) (SIGEL(I),I=1,6)
  191. 60081          FORMAT(2X,' SIGEL   '/(6(1X,1PE12.5))/)
  192.             ENDIF
  193. *
  194. *
  195.             CALL OTTOFL(NCA2,NN2,XINVL,PENT,SIGEL,GS,SMAX,XLTR,
  196.      &                  DFDS,DGDS,HDFDQ,XCOMP,XLAMC,PRECIE,
  197.      &                  PRECIZ,KERRE)
  198.             IF(KERRE.NE.0) RETURN
  199. *
  200. *
  201.       NDIM=NCA2
  202.       IF(IFOUR.EQ.-2) NDIM=NCA2+1
  203. *
  204.       IF(IIMPI.EQ.42) THEN
  205.          WRITE(IOIMP,77010) NCA2,NDIM
  206. 77010    FORMAT(5X,'NCA2=',I3,2X,'NDIM =',I3/)
  207.          WRITE(IOIMP,77018) (NN2(IJ),IJ=1,NCA2)
  208. 77018    FORMAT(5X,'NN2 ',5(1X,I3))
  209.       ENDIF
  210. *
  211.       DO IJ=1,NCA2
  212. *
  213.          JJ=NN2(IJ)
  214.          CALL OTTOPR(DDE,DGDS(1,JJ),VAUX1)
  215. *
  216.          DO IK=1,NCA2
  217.             JK=NN2(IK)
  218.             AA(IK,IJ)= DDOT(6,DFDS(1,JK),1,VAUX1,1)
  219.             IF(IK.EQ.IJ) AA(IK,IJ)=AA(IK,IJ)-HDFDQ(JK)
  220.          ENDDO
  221.          BB1(IJ)=FC(JJ)
  222.          BB2(IJ)=DDOT(6,DFDS(1,JJ),1,DSIGT,1)
  223.  
  224. *
  225. *        SPECIAL CP
  226. *
  227.          IF(IFOUR.EQ.-2) THEN
  228.             AA(IJ,NDIM)=-(DFDS(1,JJ)*DDE(1)+DFDS(2,JJ)*DDE(6)
  229.      *                   +DFDS(3,JJ)*DDE(5)+DFDS(4,JJ)*DDE(10))
  230.             AA(NDIM,IJ)=VAUX1(1)
  231.          ENDIF
  232.       ENDDO
  233. *
  234.       IF(IFOUR.EQ.-2) THEN
  235.          AA(NDIM,NDIM)=-DDE(1)
  236.          BB1(NDIM)=SIGEL(1)
  237.          BB2(NDIM)=DSIGT(1)
  238.       ENDIF
  239. *
  240. *       IF(IIMPI.EQ.42) THEN
  241. *         WRITE(IOIMP,77011) ((AA(I,J),J=1,5),I=1,5)
  242. *77011    FORMAT(5X,' MATRICE AA'/(5(1X,1PE12.5)))
  243. *         WRITE(IOIMP,77012) (BB1(I),I=1,5)
  244. *77012    FORMAT(5X,' VECTEUR BB1'/(5(1X,1PE12.5)))
  245. *         WRITE(IOIMP,70012) (BB2(I),I=1,5)
  246. *70012    FORMAT(5X,' VECTEUR BB2'/(5(1X,1PE12.5)))
  247. *       ENDIF
  248. *
  249. *
  250.       KERRE=0
  251.       CALL INVALM(AA,NC1,NDIM,KERRE,1D-10)
  252.       IF(KERRE.NE.0) THEN
  253.          PRINT *,' MATRICE SINGULIERE DANS OTTOIN '
  254.          RETURN
  255.       ENDIF
  256. *      IF(IIMPI.EQ.42) THEN
  257. *         WRITE(IOIMP,77113) ((AA(I,J),J=1,5),I=1,5)
  258. *77113    FORMAT(5X,' MATRICE AA INVERSEE '/(5(1X,1PE12.5)))
  259. *      ENDIF
  260. *
  261.       CALL MULMA2(VEC1,AA,BB1,NDIM,1,NDIM,NC1,NC1)
  262.       CALL MULMA2(VEC2,AA,BB2,NDIM,1,NDIM,NC1,NC1)
  263. *
  264.        DO IJ=1,NDIM
  265.           DDX(IJ)=VEC1(IJ)+VEC2(IJ)
  266.        ENDDO
  267.  
  268.        IF(IIMPI.EQ.42) THEN
  269.           WRITE(IOIMP,77013) (DDX(IJ),IJ=1,NDIM)
  270. 77013     FORMAT(5X,' OTTOIN - DDX CALCULE'/(5(1X,1PE12.5)))
  271.        ENDIF
  272. *
  273. *
  274.         DO IJ=1,NCA2
  275.            JJ=NN2(IJ)
  276.            DO I=1,6
  277.               DDPLAS(I)=DDPLAS(I)+DGDS(I,JJ)*DDX(IJ)
  278.            ENDDO
  279.         ENDDO
  280. *
  281.         CALL OTTOPR(DDE,DDPLAS,DSIGP)
  282. *
  283.         IF(IFOUR.EQ.-2) THEN
  284.            DSIGP(1)=DSIGP(1)-DDE(1)*DDX(NDIM)
  285.            DSIGP(2)=DSIGP(2)-DDE(6)*DDX(NDIM)
  286.            DSIGP(3)=DSIGP(3)-DDE(5)*DDX(NDIM)
  287.            DSIGP(4)=DSIGP(4)-DDE(10)*DDX(NDIM)
  288.         ENDIF
  289. *
  290.         DO I=1,6
  291.            DSIG(I)=DSIGT(I)-DSIGP(I)
  292.         ENDDO
  293.         IF(IIMPI.EQ.42) THEN
  294.            WRITE(IOIMP,79013) (DSIG(I),I=1,6)
  295. 79013      FORMAT(5X,' DSIG  CALCULE  '/(6(1X,1PE12.5)))
  296.         ENDIF
  297. *
  298. *
  299.         IFLAG=0
  300.         DO IJ=1,NCA2
  301.            JJ=NN2(IJ)
  302.            IF(ISING(JJ).EQ.1) THEN
  303.              IF(DSIG(JJ).GT.PRECIZ) IFLAG=1
  304.              IF(PENT(JJ).EQ.PENTE(JJ).AND.DDX(IJ).LT.0.D0) IFLAG=1
  305.              IF(PENT(JJ).EQ.PENTE2(JJ).AND.DDX(IJ).GT.0.D0) IFLAG=1
  306.            ENDIF
  307. *
  308.            IF(IFERM(JJ).EQ.1) THEN
  309.              IF(DDX(IJ).LT.0.D0) IFLAG=1
  310. *  AM  11/12/15  ON AJOUTE LE TEST (JJ.NE.4) CI DESSOUS
  311.              IF(JJ.NE.4.AND.DSIG(JJ).LT.-PRECIZ) IFLAG=1
  312.            ENDIF
  313.         ENDDO
  314. *
  315.         DO I=1,3
  316.            IF(IFERM(I).EQ.1.AND.LASIT(I).EQ.1) THEN
  317.               IF(DSIG(I).GT.PRECIZ) IFLAG=1
  318.            ENDIF
  319.         ENDDO
  320. *
  321.         DO I=1,3
  322.            IF(IBRUP(I).EQ.1.AND.LASIT(I).EQ.1) THEN
  323.               IF(DSIG(I).GT.PRECIZ) IFLAG=1
  324.            ENDIF
  325.         ENDDO
  326.  
  327. *
  328. *  MLR 9/7/99
  329. *
  330.         DO IJ=1,NCA
  331.            JJ=NN(IJ)
  332.            IF(JJ.EQ.4.AND.LASIT(4).EQ.1) THEN
  333.              CALL OTTOCP(SIGEL,FCR4,XLTR,DFF,DGG,H4,
  334.      &                  PRECIE,PRECIZ,XCOMP,XLAMC,KERRE)
  335. *
  336.              TRA = 0.D0
  337.              DO I=1,6
  338.                 TRA = TRA + DFF(I)*DSIG(I)
  339.              ENDDO
  340.              IF(IIMPI.EQ.42) THEN
  341.                WRITE(IOIMP,76621) TRA
  342. 76621         FORMAT(///2X,'OTTOIN  ******  TRA = ',1PE12.5//)
  343.              ENDIF
  344.              IF(TRA.GT.PRECIZ) IFLAG=1
  345.            ENDIF
  346.         ENDDO
  347. *
  348. *
  349.        IF(IFLAG.EQ.0) THEN
  350.           DO IJ=1,NCA2
  351.              JJ=NN2(IJ)
  352.              IF(ISING(JJ).EQ.1) THEN
  353.                IF(PENT(JJ).EQ.PENTE(JJ)) THEN
  354.                   ISING(JJ)=2
  355.                   LEBIL(JJ)=0
  356.                ENDIF
  357.                IF(PENT(JJ).EQ.PENTE2(JJ)) THEN
  358.                   ISING(JJ)=3
  359.                   LEBIL(JJ)=1
  360.                ENDIF
  361.              ENDIF
  362.           ENDDO
  363.           GO TO 99
  364.        ENDIF
  365.  
  366. *
  367.   55         CONTINUE
  368. *
  369.   24         CONTINUE
  370. *
  371.   23      CONTINUE
  372. *
  373.   22    CONTINUE
  374. *
  375.   21  CONTINUE
  376.  
  377.  
  378. *
  379. *     EN CAS DE PROBLEME :
  380. *
  381.       KERRE=7
  382. *   VALEUR DE KERRE A AMELIORER
  383. *
  384.              WRITE(IOIMP,73312)
  385. 73312    FORMAT(2X,'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ' /
  386.      &          4X,'ATTENTION - OTTOIN - PAS DE SOLUTION      ' /
  387.      &          2X,'ZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZZ'/)
  388.        RETURN
  389.  
  390.  
  391. *
  392.   99  CONTINUE
  393. *
  394.       CALL SHIFTD(PENT,PENTE,6)
  395.  
  396.       IF(IIMPI.EQ.42) THEN
  397.          WRITE(IOIMP,70801) (PENTE(I),I=1,NC)
  398. 70801    FORMAT(///2X,'OTTOIN  SORTIE - PENTE '/(4(1X,1PE12.5)/))
  399.          WRITE(IOIMP,76802) (LEBIL(I),I=1,NC)
  400. 76802    FORMAT(/2X,'OTTOIN  SORTIE - LEBIL '/(4I5/))
  401.          WRITE(IOIMP,76803) (ISING(I),I=1,NC)
  402. 76803    FORMAT(/2X,'OTTOIN  SORTIE - ISING '/(4I5/))
  403.        ENDIF
  404. *
  405. *     RETRAITEMENT
  406. *
  407.       NCA=NCA2
  408.       DO I=1,NCA
  409.          NN(I)=NN2(I)
  410.       ENDDO
  411. *
  412.       MC2=0
  413.       DO I=1,MC
  414. *
  415. *        TYPES 1
  416. *
  417.          IF(MM(I).GE.7.AND.MM(I).LE.9) THEN
  418.             IC=MM(I)-6
  419.             IF(ISING(IC).EQ.3) GO TO 101
  420.          ENDIF
  421.  
  422.          IF(MM(I).GE.13.AND.MM(I).LE.15) THEN
  423.             IC=MM(I)-12
  424.             IF(ISING(IC).EQ.2) GO TO 101
  425.          ENDIF
  426. *
  427. *        TYPES 2
  428. *
  429.          IF(MM(I).GE.4.AND.MM(I).LE.6) THEN
  430.             IC=MM(I)-3
  431.             IF(IFERM(IC).EQ.1.AND.JESEC(IC).EQ.0) GO TO 101
  432.          ENDIF
  433. *
  434.          MC2=MC2+1
  435.          MM(MC2)=MM(I)
  436. 101      CONTINUE
  437.       ENDDO
  438.       MC=MC2
  439.  
  440.       IF(IIMPI.EQ.42) THEN
  441.          WRITE(IOIMP,44102) NCA
  442. 44102    FORMAT(2X,'OTTOIN - NOUVELLE VALEUR NCA =',I3/)
  443.          WRITE(IOIMP,44103) (NN(IC),IC=1,NCA)
  444. 44103    FORMAT(2X,'OTTOIN - NOUVELLE LISTE NN '/16(1X,I3)/)
  445.          WRITE(IOIMP,49102) MC
  446. 49102    FORMAT(2X,'OTTOIN - NOUVELLE VALEUR MC =',I3/)
  447.          WRITE(IOIMP,49103) (MM(IC),IC=1,MC)
  448. 49103    FORMAT(2X,'OTTOIN - NOUVELLE LISTE MM '/16(1X,I3)/)
  449.       ENDIF
  450.  
  451.        RETURN
  452.        END
  453.  
  454.  
  455.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales