Télécharger la plaquette Cast3M


fr en

Télécharger surfp3.eso

Retour à la liste

Numérotation des lignes : 

surfp3

  1. C SURFP3    SOURCE    PV        22/04/26    21:15:08     11344          
  2.       SUBROUTINE SURFP3 (LIGNE1,LIGNE2,LIGNE3,LIGNE4,  LETOUR,msurfp)
  3. ************************************************************************
  4. *
  5. *                             S U R F P 3
  6. *                             -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. *     DEFINIR LE CONTOUR D'UNE SURFACE POLYNOMIALE A PARTIR DE SES 4
  12. *     COTES.
  13. *
  14. * MODULES UTILISES:
  15. * -----------------
  16. *
  17.       IMPLICIT REAL*8(A-H,O-Z)
  18.       IMPLICIT INTEGER(I-N)
  19.  
  20. -INC PPARAM
  21. -INC CCOPTIO
  22. -INC SMELEME
  23. -INC TMSURFP
  24. *
  25. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  26. * -----------
  27. *
  28. *     LIGNE1  (E)  POINTEUR DU MAILLAGE DU COTE 1.
  29. *     LIGNE2  (E)  POINTEUR DU MAILLAGE DU COTE 2.
  30. *     LIGNE3  (E)  POINTEUR DU MAILLAGE DU COTE 3.
  31. *     LIGNE4  (E)  POINTEUR DU MAILLAGE DU COTE 4.
  32. *    +MSURFP  (E)  POINTEUR DE LA SURFACE PARAMETREE.
  33. *             (S)  LES POINTS "PT1SUR", ... , "PT4SUR" PEUVENT ETRE
  34. *                  MODIFIES (ET LES "USUR" ET "VSUR" ASSOCIES).
  35. *     LETOUR  (S)  POINTEUR DU MAILLAGE DU CONTOUR.
  36. *
  37.       INTEGER LIGNE1,LIGNE2,LIGNE3,LIGNE4,LETOUR
  38. *
  39. * VARIABLES:
  40. * ----------
  41. *
  42.       INTEGER PT1,PT2,LONG
  43.       REAL*8 DSUR(16)
  44. *>>>>> P.M. 21/09/90
  45.       REAL*8 EPS1
  46. *
  47. * FONCTIONS:
  48. * ----------
  49. *
  50.       LOGICAL EGA1
  51. *
  52. *<<<<<
  53. *
  54. * AUTEUR, DATE DE CREATION:
  55. * -------------------------
  56. *
  57. *     PASCAL MANIGOT     03 MARS 1987
  58. *
  59. * LANGAGE:
  60. * --------
  61. *
  62. *     ESOPE77 FORTRAN77
  63. *
  64. ************************************************************************
  65. *
  66.       SEGACT,MSURFP
  67. *
  68.       IPT1 = LIGNE1
  69.       IPT2 = LIGNE2
  70.       IPT3 = LIGNE3
  71.       IPT4 = LIGNE4
  72.       SEGACT IPT1,IPT2,IPT3,IPT4
  73. *
  74.       ITPL = IPT1.ITYPEL
  75. *+*   IF (ITPL.NE.IPT2.ITYPEL .OR. ITPL.NE.IPT3.ITYPEL
  76. *+*   .OR. ITPL.NE.IPT4.ITYPEL) THEN
  77. *        RQ: CE CAS NE POURRA SE PRODUIRE QUE LE JOUR OU L'ON POURRA
  78. *            DONNER UN COTE EXPLICITEMENT.
  79. *+*      CALL ERREUR(16)
  80. *+*      RETURN
  81. *+*   END IF
  82. *
  83. *>>>>> P.M. 21/09/90
  84.       NOMB1 = IPT1.NUM(/2)
  85.       NOMB2 = IPT2.NUM(/2)
  86.       NOMB3 = IPT3.NUM(/2)
  87.       NOMB4 = IPT4.NUM(/2)
  88.       EPS1 = -1.
  89.       IF (.NOT. (
  90.      &   (EGA1(PT1SUR,PT2SUR,EPS1) .AND. EGA1(PT3SUR,PT4SUR,EPS1)
  91.      &   .AND. (NOMB2 .EQ. 1) .AND. (NOMB4 .EQ. 1))
  92.      &.OR.
  93.      &   (EGA1(PT2SUR,PT3SUR,EPS1) .AND. EGA1(PT4SUR,PT1SUR,EPS1)
  94.      &   .AND. (NOMB1 .EQ. 1) .AND. (NOMB3 .EQ. 1))
  95.      & )) THEN
  96. *        SI SURFACE PAS TROP PETITE, ON REGARDE S'IL NE S'AGIT PAS D'UNE
  97. *        SURFACE PARAMETREE DEGENEREE TELLE QUE:
  98. *        - ZONE TRIANGULAIRE,
  99. *        - ZONE EN FORME D'OEIL.
  100. *        ET ON INTERVIENT EN CONSEQUENCE.
  101. *<<<<<
  102. *
  103.       PT1 = PT1SUR
  104.       PT2 = PT2SUR
  105.       CALL SURFP7 (PT1,PT2,LIGNE1,LIGNE2,LIGNE3,LIGNE4,  NOMB1,msurfp)
  106. *     "PT2" A PU CHANGER DE VALEUR:
  107.       PT2SUR = PT2
  108.       PT1 = PT2SUR
  109.       PT2 = PT3SUR
  110.       CALL SURFP7 (PT1,PT2,LIGNE2,LIGNE3,LIGNE4,LIGNE1,  NOMB2,msurfp)
  111.       PT3SUR = PT2
  112.       PT1 = PT3SUR
  113.       PT2 = PT4SUR
  114.       CALL SURFP7 (PT1,PT2,LIGNE3,LIGNE4,LIGNE1,LIGNE2,  NOMB3,msurfp)
  115.       PT4SUR = PT2
  116.       PT1 = PT4SUR
  117.       PT2 = PT1SUR
  118.       CALL SURFP7 (PT1,PT2,LIGNE4,LIGNE1,LIGNE2,LIGNE3,  NOMB4,msurfp)
  119.       PT1SUR = PT2
  120. *
  121. *>>>>> P.M. 21/09/90
  122.       END IF
  123. *<<<<<
  124. *
  125.       MUVSUR=IUVSUR
  126.       SEGACT,MUVSUR
  127.       LONG=USUR(/1)
  128.       IF (IIMPI.EQ.1804) THEN
  129.          DO 800 I=1,LONG
  130.             WRITE(IOIMP,'(I5,2(2X,G12.5))')I,USUR(I),VSUR(I)
  131. 800         CONTINUE
  132. *        END DO
  133.       END IF
  134.       CALL SURFP8(.TRUE.,USUR,VSUR,DSUR,LONG,U1SUR,U2SUR,V1SUR,V2SUR,
  135.      &            NOMB1,NOMB2,NOMB3,NOMB4)
  136.       IF (IIMPI.EQ.1804) THEN
  137.          DO 810 I=1,LONG
  138.             WRITE(IOIMP,'(I5,2(2X,G12.5))')I,USUR(I),VSUR(I)
  139. 810         CONTINUE
  140. *        END DO
  141.       END IF
  142.       SEGDES,MUVSUR
  143. *
  144.       NBNN = IPT1.NUM(/1)
  145.       NBELEM = NOMB1 + NOMB2 + NOMB3 + NOMB4
  146.       NBREF=0
  147.       NBSOUS=0
  148.       SEGINI IPT5
  149.       IPT5.ITYPEL=ITPL
  150. *
  151.       DO 110 J=1,NOMB1
  152.          IPT5.ICOLOR(J) = IPT1.ICOLOR(J)
  153.          DO 110 I=1,NBNN
  154.             IPT5.NUM(I,J)=IPT1.NUM(I,J)
  155.   110       CONTINUE
  156. *        END DO
  157. *     END DO
  158.       DO 120 J=1,NOMB2
  159.          J1 = J + NOMB1
  160.          IPT5.ICOLOR(J1) = IPT2.ICOLOR(J)
  161.          DO 120 I=1,NBNN
  162.             IPT5.NUM(I,J1)=IPT2.NUM(I,J)
  163.   120       CONTINUE
  164. *        END DO
  165. *     END DO
  166.       DO 130 J=1,NOMB3
  167.          J1 = J + NOMB1 + NOMB2
  168.          IPT5.ICOLOR(J1) = IPT3.ICOLOR(J)
  169.          DO 130 I=1,NBNN
  170.             IPT5.NUM(I,J1)=IPT3.NUM(I,J)
  171.   130       CONTINUE
  172. *        END DO
  173. *     END DO
  174.       DO 140 J=1,NOMB4
  175.          J1 = J + NOMB1 + NOMB2 + NOMB3
  176.          IPT5.ICOLOR(J1) = IPT4.ICOLOR(J)
  177.          DO 140 I=1,NBNN
  178.             IPT5.NUM(I,J1)=IPT4.NUM(I,J)
  179.   140       CONTINUE
  180. *        END DO
  181. *     END DO
  182. *
  183.       SEGDES,IPT5
  184.       LETOUR = IPT5
  185. *>>>>> P.M. 04/10/90
  186. *+*   SEGSUP,IPT1,IPT2,IPT3,IPT4
  187.       SEGDES,IPT1,IPT2,IPT3,IPT4
  188. *<<<<<
  189. *
  190.       END
  191.  
  192.  
  193.  
  194.  
  195.  
  196.  

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