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    CB215821  26/08/24    21:18:28     12622          
  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 241 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.   241    CONTINUE
  120. *           END DO
  121. *        END DO
  122.       ELSE
  123.          DO 242 IB1=1,IDIM
  124.             DO 120 IB2=1,N
  125.                COFCOU(IB2,IB1)
  126.      &               = POLYNO (COFSUR(IB2,1,IB1),NCOSUR,NLISUR,U2SUR)
  127.   120          CONTINUE
  128.   242    CONTINUE
  129. *           END DO
  130. *        END DO
  131.       END IF
  132.       SEGDES,MCOFSU
  133. *
  134.       CALL COURB2 (MCOURB,  LIGNE1)
  135.       IF (IERR .NE. 0) RETURN
  136.       SEGDES,MCOURB
  137. *
  138. *     -- CREATION DU COTE N.3 :  U DE U2SUR A U1SUR ; V = V2SUR --
  139. *  OU
  140. *     -- CREATION DU COTE N.4 :  U = U1SUR ; V DE V2SUR A V1SUR --
  141. *
  142.       LONG = 0
  143.       SEGINI,MCOUR1
  144. *
  145.       MCOUR1.NLMCOU = 0
  146.       MCOUR1.D1COU = DENSIT
  147.       MCOUR1.D2COU = DENSIT
  148.       MCOUR1.LI1COU = 0
  149.       MCOUR1.LI2COU = 0
  150.       MCOUR1.REGCOU = REGSUR
  151.       IF (UVARIE) THEN
  152.          MCOUR1.U1COU = U2SUR
  153.          MCOUR1.U2COU = U1SUR
  154.          MCOUR1.PT1COU = PT3SUR
  155.          MCOUR1.PT2COU = PT4SUR
  156.          MCOUR1.ND1COU = NCOSUR
  157.       ELSE
  158.          MCOUR1.U1COU = V2SUR
  159.          MCOUR1.U2COU = V1SUR
  160.          MCOUR1.PT1COU = PT4SUR
  161.          MCOUR1.PT2COU = PT1SUR
  162.          MCOUR1.ND1COU = NLISUR
  163.       END IF
  164. *
  165.       SEGACT,MCOFSU*MOD
  166.       N = MCOUR1.ND1COU
  167.       SEGINI,MCOFC1
  168.       MCOUR1.ICOFCO = MCOFC1
  169.       IF (UVARIE) THEN
  170.          DO 243 IB1=1,IDIM
  171.             DO 130 IB2=1,N
  172.                MCOFC1.COFCOU(IB2,IB1)
  173.      &               = POLYNO (COFSUR(1,IB2,IB1),NLISUR,1,V2SUR)
  174.   130          CONTINUE
  175.   243    CONTINUE
  176. *           END DO
  177. *        END DO
  178.       ELSE
  179.          DO 244 IB1=1,IDIM
  180.             DO 140 IB2=1,N
  181.                MCOFC1.COFCOU(IB2,IB1)
  182.      &               = POLYNO (COFSUR(IB2,1,IB1),NCOSUR,NLISUR,U1SUR)
  183.   140          CONTINUE
  184.   244    CONTINUE
  185. *           END DO
  186. *        END DO
  187.       END IF
  188.       SEGDES,MCOFSU
  189. *
  190.       CALL COURB2 (MCOUR1,  LIGNE3)
  191.       IF (IERR .NE. 0) RETURN
  192.       SEGDES,MCOUR1
  193. *
  194.       IF (OPERAT .EQ. DALL) THEN
  195. *        LES COTES OPPOSES DOIVENT AVOIR MEME NOMBRE D'ELEMENTS DANS LE
  196. *        CAS D'UN DALLAGE.
  197. *
  198.          SEGACT,MCOURB*MOD,MCOUR1*MOD
  199.          NLM = NLMCOU
  200.          NL1 = MCOUR1.NLMCOU
  201.          IF (NLM .NE. NL1) THEN
  202.             IF (NL1.EQ.(NLM-1) .OR. NL1.EQ.(NLM+1) ) THEN
  203.                SEGDES,MCOURB
  204.                CALL COURB9 (MCOUR1,LIGNE3)
  205.                SEGACT,MCOUR1*MOD
  206.                MCOUR1.NLMCOU = NLM
  207.                CALL COURB2 (MCOUR1,LIGNE3)
  208.                IF (IERR .NE. 0) RETURN
  209.                SEGDES,MCOUR1
  210.             ELSE
  211. *              APPELS "COURB9" EN SENS INVERSE DE L'ORDRE DE CREATION:
  212.                CALL COURB9 (MCOUR1,LIGNE3)
  213.                CALL COURB9 (MCOURB,LIGNE1)
  214.                NLM = (NLM + NL1) / 2
  215.                SEGACT,MCOURB*MOD
  216.                NLMCOU = NLM
  217.                CALL COURB2 (MCOURB,LIGNE1)
  218.                IF (IERR .NE. 0) RETURN
  219.                SEGDES,MCOURB
  220.                SEGACT,MCOUR1*MOD
  221.                MCOUR1.NLMCOU = NLM
  222.                CALL COURB2 (MCOUR1,LIGNE3)
  223.                IF (IERR .NE. 0) RETURN
  224.                SEGDES,MCOUR1
  225.             END IF
  226.          ELSE
  227.             SEGDES,MCOURB,MCOUR1
  228.          END IF
  229.       END IF
  230. *
  231.       SEGSUP,MCOFCO,MCOFC1
  232. *
  233. *     REMPLISSAGE DE LA TABLE DES COORDONNEES PARAMETRIQUES DU CONTOUR:
  234. *
  235.       SEGACT,MUVSUR*MOD
  236.       SEGACT,MCOURB*MOD,MCOUR1*MOD
  237.       LONG0 = USUR(/1)
  238.       LONG1 = UCOU(/1)
  239.       LONG3 = MCOUR1.UCOU(/1)
  240.       LONG = LONG0 + LONG1 + LONG3
  241.       SEGADJ,MUVSUR
  242. *
  243.       IF (UVARIE) THEN
  244.          DO 210 IB=(LONG0+1),(LONG0+LONG1)
  245.             USUR(IB) = UCOU(IB-LONG0)
  246.             VSUR(IB) = V1SUR
  247.   210       CONTINUE
  248. *        END DO
  249.          LONG01 = LONG0 + LONG1
  250.          DO 230 IB=(LONG01+1),LONG
  251.             USUR(IB) = MCOUR1.UCOU(IB-LONG01)
  252.             VSUR(IB) = V2SUR
  253.   230       CONTINUE
  254. *        END DO
  255.       ELSE
  256.          DO 220 IB=(LONG0+1),(LONG0+LONG1)
  257.             VSUR(IB) = UCOU(IB-LONG0)
  258.             USUR(IB) = U2SUR
  259.   220       CONTINUE
  260. *        END DO
  261.          LONG01 = LONG0 + LONG1
  262.          DO 240 IB=(LONG01+1),LONG
  263.             VSUR(IB) = MCOUR1.UCOU(IB-LONG01)
  264.             USUR(IB) = U1SUR
  265.   240       CONTINUE
  266. *        END DO
  267.       END IF
  268. *
  269.       SEGDES,MUVSUR
  270.       SEGSUP,MCOURB,MCOUR1
  271. *
  272.       END
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  

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