Télécharger la plaquette Cast3M


fr en

Télécharger impos6.eso

Retour à la liste

Numérotation des lignes : 

impos6

  1. C IMPOS6    SOURCE    CHAT      05/01/13    00:34:02     5004
  2.       SUBROUTINE IMPOS6(IMCTC1,IMCTC2,ICODE)
  3. c
  4. c      pour cavi
  5. c      assemble deux mctc de cavi1
  6. c      le resultat est mis dans imctc2
  7. c
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8 (A-H,O-Z)
  10. -INC SMCOORD
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14.       SEGMENT MCTC
  15.         INTEGER IPOT1(NNO1)
  16.         INTEGER IPOT2(NNO2)
  17.       ENDSEGMENT
  18.       POINTEUR MCTC1.MCTC,MCTC2.MCTC,MCTC3.MCTC
  19.       LOGICAL FLAG
  20. c
  21. c executable
  22. c
  23.       MCTC1 = IMCTC1
  24.       MCTC2 = IMCTC2
  25.       IF ( ICODE .EQ. -1 ) THEN
  26. c  les segments sont inversés entre les deux lignes de points on renverse mctc2
  27.            NNO2 = MCTC2.IPOT1(/1)
  28.            NNO1 = MCTC2.IPOT2(/1)
  29.            SEGINI MCTC
  30.            DO 100 I=1,NNO1
  31.               IPOT1(I)=MCTC2.IPOT2(I)
  32.  100       CONTINUE
  33.            DO 200 I=1,NNO2
  34.               IPOT2(I)=MCTC2.IPOT1(I)
  35.  200       CONTINUE
  36.            SEGSUP MCTC2
  37.            MCTC2 = MCTC
  38.        ENDIF
  39. c
  40. c  nombre de points dans la premiere ligne du nouveau mctc
  41. c
  42.       NNO1 = MCTC1.IPOT1(/1) + MCTC2.IPOT1(/1)
  43.       DO 300 I=1,MCTC2.IPOT1(/1)
  44.         DO 250 J=1,MCTC1.IPOT1(/1)
  45.           IF ( MCTC2.IPOT1(I) .EQ. MCTC1.IPOT1(J)) THEN
  46.              MCTC2.IPOT1(I) = -J
  47.              NNO1 = NNO1 - 1
  48.              GOTO 300
  49.           ENDIF
  50.  250    CONTINUE
  51.  300  CONTINUE
  52. c
  53. c  nombre de points de la deuxieme ligne du nouveau mctc
  54. c
  55.       NNO2 = MCTC1.IPOT2(/1) + MCTC2.IPOT2(/1)
  56.       DO 400 I=1,MCTC2.IPOT2(/1)
  57.         DO 350 J=1,MCTC1.IPOT2(/1)
  58.           IF ( MCTC2.IPOT2(I) .EQ. MCTC1.IPOT2(J)) THEN
  59.              MCTC2.IPOT2(I) = -J
  60.              NNO2 = NNO2 - 1
  61.              GOTO 400
  62.           ENDIF
  63.  350    CONTINUE
  64.  400  CONTINUE
  65. c     initialisation du nouveau mctc3 avec nno1 et nno2
  66.       SEGINI MCTC3
  67. c
  68. c  introduction des points de mctc1 dans mctc3
  69. c
  70.       DO 500 I=1,MCTC1.IPOT1(/1)
  71.          MCTC3.IPOT1(I)=MCTC1.IPOT1(I)
  72.  500  CONTINUE
  73.       DO 600 I=1,MCTC1.IPOT2(/1)
  74.          MCTC3.IPOT2(I)=MCTC1.IPOT2(I)
  75.  600  CONTINUE
  76. c
  77. c introduction des points de mctc2 dans mctc3
  78. c on doit trier pour les mettre a la bonne place
  79. c
  80. c    1ere couche
  81. c
  82.       INDI1 = MCTC1.IPOT1(/1)
  83.       INDI2 = 1
  84. c     indi1 est le niveau de remplissage de mctc3.ipot1
  85. c     indi2 indique le point le plus en avant que l'on ait place
  86.       DO 700 I=1,MCTC2.IPOT1(/1)
  87.         IF (MCTC2.IPOT1(I) .GT. 0) THEN
  88.           IM = MCTC2.IPOT1(I)
  89.           DO 650 J=INDI2,INDI1-1
  90. c         boucle sur les points deja mis dans mctc3
  91. c         on cherche a placer le nouveau point au bon endroit
  92.              IA = MCTC3.IPOT1(J)
  93.              IB = MCTC3.IPOT1(J+1)
  94.              XAB = XCOOR((IB-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1)
  95.              YAB = XCOOR((IB-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2)
  96.              XAM = XCOOR((IM-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1)
  97.              YAM = XCOOR((IM-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2)
  98.              PL1 = XAB*XAB + YAB*YAB
  99.              PL2 = XAB*XAM + YAB*YAM
  100.              PL3 = XAM*XAM + YAM*YAM
  101. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  102.              IF ((PL2 .LE. 0.D0) .AND. ((PL3/PL1).LT. 4.)) THEN
  103. c          le point ce trouve a gauche de A a une distance raisonnable
  104.                 DO 640 K=INDI1,J,-1
  105.                     MCTC3.IPOT1(K+1)=MCTC3.IPOT1(K)
  106.  640            CONTINUE
  107.                 INDI1 = INDI1 + 1
  108. *                print *,'a gauche'
  109. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  110.                 MCTC3.IPOT1(J)=IM
  111.                 INDI2 = J
  112.                 GOTO 700
  113.               ENDIF
  114.              IF ((PL2 .GT.0.) .AND. ((PL3/PL1).LT. 1.)) THEN
  115. c               le point ce trouve a gauche de B
  116.                 DO 645 K=INDI1,J+1,-1
  117.                     MCTC3.IPOT1(K+1)=MCTC3.IPOT1(K)
  118.  645            CONTINUE
  119.                 MCTC3.IPOT1(J+1)=IM
  120. *                print *,'a droite'
  121. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  122.                 INDI2 = J+1
  123.                 INDI1 = INDI1 + 1
  124.                 GOTO 700
  125.              ENDIF
  126.  650      CONTINUE
  127. c
  128.           IF (INDI1 .EQ. 1) THEN
  129. c            la ligne ne contient q'un seul point
  130. c            on se base sur la deuxieme ligne
  131.              IA = MCTC3.IPOT2(1)
  132.              IB = MCTC3.IPOT2(2)
  133.              IC = MCTC3.IPOT1(1)
  134.              XAB = XCOOR((IB-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1)
  135.              YAB = XCOOR((IB-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2)
  136.              XCM = XCOOR((IM-1)*(IDIM+1)+1)-XCOOR((IC-1)*(IDIM+1)+1)
  137.              YCM = XCOOR((IM-1)*(IDIM+1)+2)-XCOOR((IC-1)*(IDIM+1)+2)
  138.              PL1 = XAB*XCM+YAB*YCM
  139.              IF ( PL1 .GT. 0) THEN
  140.                MCTC3.IPOT1(1)=IM
  141. *                print *,'unique'
  142. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  143.                MCTC3.IPOT1(2)=IC
  144.                INDI1 = 2
  145.                GOTO 700
  146.              ENDIF
  147.           ENDIF
  148.  
  149. c         le point se trouve a droite de tout
  150.           INDI1 = INDI1 + 1
  151.           MCTC3.IPOT1(INDI1)=IM
  152. *          print *,'extreme'
  153. *          print *,'im=',im
  154.           INDI2 = INDI1
  155.         ELSE
  156.           INDI2 = -MCTC2.IPOT1(I)
  157.         ENDIF
  158.  700  CONTINUE
  159. c
  160. c    2ieme couche
  161. c
  162.       INDI1 = MCTC1.IPOT2(/1)
  163.       INDI2 = 1
  164. c     indi1 est le niveau de remplissage de mctc3.ipot2
  165.       DO 800 I=1,MCTC2.IPOT2(/1)
  166.         IF (MCTC2.IPOT2(I) .GT. 0) THEN
  167.           IM = MCTC2.IPOT2(I)
  168.           DO 750 J=INDI2,INDI1-1
  169. c         boucle sur les points deja mis dans mctc3
  170.              IA = MCTC3.IPOT2(J)
  171.              IB = MCTC3.IPOT2(J+1)
  172.              XAB = XCOOR((IB-1)*(IDIM+1)+1) - XCOOR((IA-1)*(IDIM+1)+1)
  173.              YAB = XCOOR((IB-1)*(IDIM+1)+2) - XCOOR((IA-1)*(IDIM+1)+2)
  174.              XAM = XCOOR((IM-1)*(IDIM+1)+1) - XCOOR((IA-1)*(IDIM+1)+1)
  175.              YAM = XCOOR((IM-1)*(IDIM+1)+2) - XCOOR((IA-1)*(IDIM+1)+2)
  176.              PL1 = XAB*XAB + YAB*YAB
  177.              PL2 = XAB*XAM + YAB*YAM
  178.              PL3 = XAM*XAM + YAM*YAM
  179. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  180.              IF ((PL2 .LT. 0.D0) .AND. ((PL3/PL1) .LT. 4.)) THEN
  181. c            le point ce trouve a gauche de A
  182.                 DO 740 K=INDI1,J,-1
  183.                     MCTC3.IPOT2(K+1)=MCTC3.IPOT2(K)
  184.  740            CONTINUE
  185.                 INDI1 = INDI1 + 1
  186.                 INDI2 = J
  187.                 MCTC3.IPOT2(J)=IM
  188. *                print *,'a gauche'
  189. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  190.                 GOTO 800
  191.              ENDIF
  192.              IF ((PL2 .GE. 0.D0) .AND. ((PL3/PL1).LT. 1.)) THEN
  193. c               le point ce trouve a gauche de B
  194.                 DO 745 K=INDI1,J+1,-1
  195.                     MCTC3.IPOT2(K+1)=MCTC3.IPOT2(K)
  196.  745            CONTINUE
  197.                 MCTC3.IPOT2(J+1)=IM
  198. *                print *,'a droite'
  199. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  200.                 INDI2 = J+1
  201.                 INDI1 = INDI1 + 1
  202.                 GOTO 800
  203.              ENDIF
  204.  750      CONTINUE
  205.           IF (INDI1 .EQ. 1) THEN
  206.              IA = MCTC3.IPOT1(1)
  207.              IB = MCTC3.IPOT1(2)
  208.              IC = MCTC3.IPOT2(1)
  209.              XAB = XCOOR((IB-1)*(IDIM+1)+1)-XCOOR((IA-1)*(IDIM+1)+1)
  210.              YAB = XCOOR((IB-1)*(IDIM+1)+2)-XCOOR((IA-1)*(IDIM+1)+2)
  211.              XCM = XCOOR((IM-1)*(IDIM+1)+1)-XCOOR((IC-1)*(IDIM+1)+1)
  212.              YCM = XCOOR((IM-1)*(IDIM+1)+2)-XCOOR((IC-1)*(IDIM+1)+2)
  213.              PL1 = XAB*XCM+YAB*YCM
  214.              IF ( PL1 .GT. 0) THEN
  215.                MCTC3.IPOT2(1)=IM
  216.                MCTC3.IPOT2(2)=IC
  217. *                print *,'unique'
  218. *                print *,'im=',im,'ia=',ia,'ib=',ib,pl1,pl2,pl3
  219.                INDI1 = 2
  220.                GOTO 800
  221.              ENDIF
  222.           ENDIF
  223. c        le point se trouve a droite de tout
  224.           INDI1 = INDI1 + 1
  225.           MCTC3.IPOT2(INDI1)=IM
  226.           INDI2 = INDI1
  227. *          print *,'extreme'
  228. *          print *,'im=',im
  229.         ELSE
  230.           INDI2 = -MCTC2.IPOT2(I)
  231.         ENDIF
  232.  800  CONTINUE
  233. c
  234. c
  235. c
  236.       SEGSUP MCTC2
  237.       IMCTC2 = MCTC3
  238.       RETURN
  239.       END
  240.  
  241.  
  242.  

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