Télécharger la plaquette Cast3M


fr en

Télécharger surfp4.eso

Retour à la liste

Numérotation des lignes : 

surfp4

  1. C SURFP4    SOURCE    BP208322  16/11/18    21:21:24     9177           
  2.       SUBROUTINE SURFP4 (OPERAT,UVARIE,LIGNE1,LIGNE3,msurfp)
  3. ************************************************************************
  4. *
  5. *                             S U R F P 4
  6. *                             -----------
  7. *
  8. * FONCTION:
  9. * ---------
  10. *
  11. *     CREER 2 COTES OPPOSES D'UNE SURFACE PARAMETREE.
  12. *
  13. * MODULES UTILISES:
  14. * -----------------
  15. *
  16.       IMPLICIT REAL*8(A-H,O-Z)
  17.       IMPLICIT INTEGER(I-N)
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC CCGEOME
  22. -INC SMCOORD
  23. -INC TMCOURB
  24. -INC TMSURFP
  25. *
  26. * PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
  27. * -----------
  28. *
  29. *     OPERAT  (E)  NOM DE L'OPERATEUR COURANT.
  30. *     UVARIE  (E)  = .TRUE. SI ON S'OCCUPE DES COTES OU LE PARAMETRE
  31. *                  "U" VARIE (CE QUI EQUIVAUT A "V" CONSTANT).
  32. *                  = .FALSE. SINON.
  33. *     LIGNE1  (S)  POINTEUR DE "MAILLAGE". COTE DE LA SURFACE.
  34. *     LIGNE3  (S)  POINTEUR DE "MAILLAGE". COTE OPPOSE A "LIGNE1".
  35. *    +MSURFP  (E)  POINTEUR DE LA SURFACE PARAMETREE.
  36. *             (S)  LAISSE DANS L'ETAT ACTIF.
  37. *                  COMPLETION DU SEGMENT.
  38. *    +DENSIT  (E)  VOIR LE COMMUN "CGEOME".
  39. *    +IDIM    (E)  VOIR LE COMMUN "COPTIO".
  40. *    +MCOORD  (E)  VOIR LE COMMUN "COPTIO".
  41. *             (S)  LE SEGMENT ASSOCIE EST ETENDU (AVEC LES POINTS
  42. *                  INTERIEURS DES COTES OPPOSES).
  43. *
  44.       CHARACTER*4 OPERAT
  45.       LOGICAL UVARIE
  46.       INTEGER LIGNE1,LIGNE3
  47. *
  48. * VARIABLES:
  49. * ----------
  50. *
  51.       POINTEUR MCOUR1.MCOURB,MCOFC1.MCOFCO
  52. *
  53. * CONSTANTES:
  54. * -----------
  55. *
  56.       CHARACTER*4 DALL
  57.       PARAMETER (DALL = 'DALL')
  58. *
  59. * FONCTIONS:
  60. * ----------
  61. *
  62.       REAL*8 POLYNO
  63. *
  64. * AUTEUR, DATE DE CREATION:
  65. * -------------------------
  66. *
  67. *     PASCAL MANIGOT     6 MARS 1987
  68. *
  69. * LANGAGE:
  70. * --------
  71. *
  72. *     ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
  73. *
  74. ************************************************************************
  75. *
  76.       SEGACT,MCOORD*MOD
  77.       SEGACT,MSURFP*MOD
  78.       MCOFSU = ICOFSU
  79.       MUVSUR = IUVSUR
  80. *
  81. *
  82. *     -- CREATION DU COTE N.1 :  U DE U1SUR A U2SUR ; V = V1SUR --
  83. *  OU
  84. *     -- CREATION DU COTE N.2 :  U = U2SUR ; V DE V1SUR A V2SUR --
  85. *
  86.       LONG = 0
  87.       SEGINI,MCOURB
  88. *
  89.       NLMCOU = 0
  90.       D1COU = DENSIT
  91.       D2COU = DENSIT
  92.       LI1COU = 0
  93.       LI2COU = 0
  94.       REGCOU = REGSUR
  95.       IF (UVARIE) THEN
  96.          U1COU = U1SUR
  97.          U2COU = U2SUR
  98.          PT1COU = PT1SUR
  99.          PT2COU = PT2SUR
  100.          ND1COU = NCOSUR
  101.       ELSE
  102.          U1COU = V1SUR
  103.          U2COU = V2SUR
  104.          PT1COU = PT2SUR
  105.          PT2COU = PT3SUR
  106.          ND1COU = NLISUR
  107.       END IF
  108. *
  109.       SEGACT,MCOFSU*MOD
  110.       N = ND1COU
  111.       SEGINI,MCOFCO
  112.       ICOFCO = MCOFCO
  113.       IF (UVARIE) THEN
  114.          DO 110 IB1=1,IDIM
  115.             DO 110 IB2=1,N
  116.                COFCOU(IB2,IB1)
  117.      &               = POLYNO (COFSUR(1,IB2,IB1),NLISUR,1,V1SUR)
  118.   110          CONTINUE
  119. *           END DO
  120. *        END DO
  121.       ELSE
  122.          DO 120 IB1=1,IDIM
  123.             DO 120 IB2=1,N
  124.                COFCOU(IB2,IB1)
  125.      &               = POLYNO (COFSUR(IB2,1,IB1),NCOSUR,NLISUR,U2SUR)
  126.   120          CONTINUE
  127. *           END DO
  128. *        END DO
  129.       END IF
  130.       SEGDES,MCOFSU
  131. *
  132.       CALL COURB2 (MCOURB,  LIGNE1)
  133.       IF (IERR .NE. 0) RETURN
  134.       SEGDES,MCOURB
  135. *
  136. *     -- CREATION DU COTE N.3 :  U DE U2SUR A U1SUR ; V = V2SUR --
  137. *  OU
  138. *     -- CREATION DU COTE N.4 :  U = U1SUR ; V DE V2SUR A V1SUR --
  139. *
  140.       LONG = 0
  141.       SEGINI,MCOUR1
  142. *
  143.       MCOUR1.NLMCOU = 0
  144.       MCOUR1.D1COU = DENSIT
  145.       MCOUR1.D2COU = DENSIT
  146.       MCOUR1.LI1COU = 0
  147.       MCOUR1.LI2COU = 0
  148.       MCOUR1.REGCOU = REGSUR
  149.       IF (UVARIE) THEN
  150.          MCOUR1.U1COU = U2SUR
  151.          MCOUR1.U2COU = U1SUR
  152.          MCOUR1.PT1COU = PT3SUR
  153.          MCOUR1.PT2COU = PT4SUR
  154.          MCOUR1.ND1COU = NCOSUR
  155.       ELSE
  156.          MCOUR1.U1COU = V2SUR
  157.          MCOUR1.U2COU = V1SUR
  158.          MCOUR1.PT1COU = PT4SUR
  159.          MCOUR1.PT2COU = PT1SUR
  160.          MCOUR1.ND1COU = NLISUR
  161.       END IF
  162. *
  163.       SEGACT,MCOFSU*MOD
  164.       N = MCOUR1.ND1COU
  165.       SEGINI,MCOFC1
  166.       MCOUR1.ICOFCO = MCOFC1
  167.       IF (UVARIE) THEN
  168.          DO 130 IB1=1,IDIM
  169.             DO 130 IB2=1,N
  170.                MCOFC1.COFCOU(IB2,IB1)
  171.      &               = POLYNO (COFSUR(1,IB2,IB1),NLISUR,1,V2SUR)
  172.   130          CONTINUE
  173. *           END DO
  174. *        END DO
  175.       ELSE
  176.          DO 140 IB1=1,IDIM
  177.             DO 140 IB2=1,N
  178.                MCOFC1.COFCOU(IB2,IB1)
  179.      &               = POLYNO (COFSUR(IB2,1,IB1),NCOSUR,NLISUR,U1SUR)
  180.   140          CONTINUE
  181. *           END DO
  182. *        END DO
  183.       END IF
  184.       SEGDES,MCOFSU
  185. *
  186.       CALL COURB2 (MCOUR1,  LIGNE3)
  187.       IF (IERR .NE. 0) RETURN
  188.       SEGDES,MCOUR1
  189. *
  190.       IF (OPERAT .EQ. DALL) THEN
  191. *        LES COTES OPPOSES DOIVENT AVOIR MEME NOMBRE D'ELEMENTS DANS LE
  192. *        CAS D'UN DALLAGE.
  193. *
  194.          SEGACT,MCOURB*MOD,MCOUR1*MOD
  195.          NLM = NLMCOU
  196.          NL1 = MCOUR1.NLMCOU
  197.          IF (NLM .NE. NL1) THEN
  198.             IF (NL1.EQ.(NLM-1) .OR. NL1.EQ.(NLM+1) ) THEN
  199.                SEGDES,MCOURB
  200.                CALL COURB9 (MCOUR1,LIGNE3)
  201.                SEGACT,MCOUR1*MOD
  202.                MCOUR1.NLMCOU = NLM
  203.                CALL COURB2 (MCOUR1,LIGNE3)
  204.                IF (IERR .NE. 0) RETURN
  205.                SEGDES,MCOUR1
  206.             ELSE
  207. *              APPELS "COURB9" EN SENS INVERSE DE L'ORDRE DE CREATION:
  208.                CALL COURB9 (MCOUR1,LIGNE3)
  209.                CALL COURB9 (MCOURB,LIGNE1)
  210.                NLM = (NLM + NL1) / 2
  211.                SEGACT,MCOURB*MOD
  212.                NLMCOU = NLM
  213.                CALL COURB2 (MCOURB,LIGNE1)
  214.                IF (IERR .NE. 0) RETURN
  215.                SEGDES,MCOURB
  216.                SEGACT,MCOUR1*MOD
  217.                MCOUR1.NLMCOU = NLM
  218.                CALL COURB2 (MCOUR1,LIGNE3)
  219.                IF (IERR .NE. 0) RETURN
  220.                SEGDES,MCOUR1
  221.             END IF
  222.          ELSE
  223.             SEGDES,MCOURB,MCOUR1
  224.          END IF
  225.       END IF
  226. *
  227.       SEGSUP,MCOFCO,MCOFC1
  228. *
  229. *     REMPLISSAGE DE LA TABLE DES COORDONNEES PARAMETRIQUES DU CONTOUR:
  230. *
  231.       SEGACT,MUVSUR*MOD
  232.       SEGACT,MCOURB*MOD,MCOUR1*MOD
  233.       LONG0 = USUR(/1)
  234.       LONG1 = UCOU(/1)
  235.       LONG3 = MCOUR1.UCOU(/1)
  236.       LONG = LONG0 + LONG1 + LONG3
  237.       SEGADJ,MUVSUR
  238. *
  239.       IF (UVARIE) THEN
  240.          DO 210 IB=(LONG0+1),(LONG0+LONG1)
  241.             USUR(IB) = UCOU(IB-LONG0)
  242.             VSUR(IB) = V1SUR
  243.   210       CONTINUE
  244. *        END DO
  245.          LONG01 = LONG0 + LONG1
  246.          DO 230 IB=(LONG01+1),LONG
  247.             USUR(IB) = MCOUR1.UCOU(IB-LONG01)
  248.             VSUR(IB) = V2SUR
  249.   230       CONTINUE
  250. *        END DO
  251.       ELSE
  252.          DO 220 IB=(LONG0+1),(LONG0+LONG1)
  253.             VSUR(IB) = UCOU(IB-LONG0)
  254.             USUR(IB) = U2SUR
  255.   220       CONTINUE
  256. *        END DO
  257.          LONG01 = LONG0 + LONG1
  258.          DO 240 IB=(LONG01+1),LONG
  259.             VSUR(IB) = MCOUR1.UCOU(IB-LONG01)
  260.             USUR(IB) = U1SUR
  261.   240       CONTINUE
  262. *        END DO
  263.       END IF
  264. *
  265.       SEGDES,MUVSUR
  266.       SEGSUP,MCOURB,MCOUR1
  267. *
  268.       END
  269.  
  270.  
  271.  
  272.  
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  

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