Télécharger courb1.eso

Retour à la liste

Numérotation des lignes :

  1. C COURB1 SOURCE BP208322 16/11/18 21:15:56 9177
  2. SUBROUTINE COURB1 (MCOURB,LIGNE)
  3. implicit real*8 (a-h,o-z)
  4. ************************************************************************
  5. *
  6. * C O U R B 1
  7. * -----------
  8. *
  9. * FONCTION:
  10. * ---------
  11. *
  12. * EXECUTE LA TACHE DE L'OPERATEUR "COURBE".
  13. *
  14. * MODULES UTILISES:
  15. * -----------------
  16. *
  17. IMPLICIT INTEGER(I-N)
  18. -INC CCOPTIO
  19. -INC CCGEOME
  20. -INC SMCOORD
  21. -INC SMELEME
  22. -INC TMCOURB
  23. *
  24. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  25. * -----------
  26. *
  27. * MCOURB (E) SEGMENT ACTIF.
  28. * +DENSIT (E) VOIR LE COMMUN "CGEOME".
  29. * +IDIM (E) VOIR LE COMMUN "COPTIO".
  30. * +MCOORD (E) VOIR LE COMMUN "COPTIO".
  31. * LIGNE (S) OBJET 'MAILLAGE' CREE.
  32. *
  33. * VARIABLES:
  34. * ----------
  35. *
  36. * NOXTRM = .TRUE. SI AUCUN POINT-EXTREMITE CONVENABLE N'A ETE
  37. * FOURNI (UTILISE DANS LA PROCEDURE INTERNE, A LA FIN).
  38. * DIST = DISTANCE ENTRE POINT FOURNI POUR EXTREMITE ET VERITABLE
  39. * POINT EXTREME DE LA COURBE.
  40. * X1COU, )
  41. * X2COU, ) COORDONNEES DES POINTS EXTREMITES DE LA COURBE.
  42. * Y1COU, )
  43. * ETC... )
  44. *
  45. INTEGER PT0COU,LI0COU
  46. LOGICAL NOXTRM,ltelq
  47. REAL*8 X1COU,Y1COU,Z1COU,X2COU,Y2COU,Z2COU
  48. REAL*8 X0COU,Y0COU,Z0COU,D0COU
  49. *
  50. * FONCTIONS:
  51. * ----------
  52. *
  53. REAL*8 POLYNO
  54. *
  55. * AUTEUR, DATE DE CREATION:
  56. * -------------------------
  57. *
  58. * PASCAL MANIGOT 10 SEPTEMBRE 1986
  59. * P.M. 24/02/87 : REMODELAGE, AVEC UN NOUVEAU SEGMENT "MCOURB".
  60. *
  61. * LANGAGE:
  62. * ------
  63. *
  64. * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
  65. *
  66. ************************************************************************
  67. *
  68. SEGACT,MCOORD
  69. *
  70. * RECHERCHE DES POINTS EXTREMES EN CAS DE DONNEE DE COURBES A
  71. * RACCORDER:
  72. *
  73. IF (LI1COU .NE. 0) THEN
  74. * ON RELEVE LE DERNIER POINT DE LA LIGNE A RACCORDER EN TETE DE
  75. * LA COURBE:
  76. N = 1
  77. * (CURIEUSEMENT, C'EST LA VALEUR "1" QUI PERMET D'EXTRAIRE LE
  78. * DERNIER POINT)
  79. LI0COU = LI1COU
  80. IPT6=LI0COU
  81. SEGACT IPT6
  82. CALL EXTRPO (LI0COU,N, PT0COU)
  83. IF (IERR .NE. 0) RETURN
  84. PT1COU = PT0COU
  85. END IF
  86. *
  87. IF (LI2COU .NE. 0) THEN
  88. * ON RELEVE LE 1ER POINT DE LA LIGNE A RACCORDER A LA FIN DE LA
  89. * COURBE:
  90. N = 2
  91. LI0COU = LI2COU
  92. IPT6=LI0COU
  93. SEGACT IPT6
  94. CALL EXTRPO (LI0COU,N, PT0COU)
  95. IF (IERR .NE. 0) RETURN
  96. PT2COU = PT0COU
  97. END IF
  98. *
  99. * CALCUL DES COORDONNEES DES POINTS EXTREMES.
  100. *
  101. MCOFCO = ICOFCO
  102. SEGACT,MCOFCO
  103. X1COU = POLYNO (COFCOU(1,1),ND1COU,1,U1COU)
  104. X2COU = POLYNO (COFCOU(1,1),ND1COU,1,U2COU)
  105. Y1COU = POLYNO (COFCOU(1,2),ND1COU,1,U1COU)
  106. Y2COU = POLYNO (COFCOU(1,2),ND1COU,1,U2COU)
  107. IF (IDIM .EQ. 3) THEN
  108. Z1COU = POLYNO (COFCOU(1,3),ND1COU,1,U1COU)
  109. Z2COU = POLYNO (COFCOU(1,3),ND1COU,1,U2COU)
  110. END IF
  111. SEGDES,MCOFCO
  112. *
  113. * LES POINTS EXTREMES FOURNIS EXPLICITEMENT (LE CAS ECHEANT)
  114. * SONT-ILS ACCEPTABLES ?
  115. * (SINON, CREATION DE NOUVEAUX)
  116. *
  117. * APPEL PROCEDURE INTERNE:
  118. PT0COU = PT1COU
  119. X0COU = X1COU
  120. Y0COU = Y1COU
  121. IF (IDIM .EQ. 3) Z0COU = Z1COU
  122. D0COU = D1COU
  123. * ASSIGN 105 TO IRTURN
  124. irturn=105
  125. GOTO 500
  126. 105 CONTINUE
  127. * RETOUR DE PROCEDURE INTERNE.
  128. IF (PT1COU .NE. 0 .AND. PT1COU .NE. PT0COU) THEN
  129. IF (LI1COU .EQ. 0) THEN
  130. CALL ERREUR (295)
  131. ELSE
  132. CALL ERREUR (297)
  133. END IF
  134. * IL N'Y A PAS LIEU DE S'ARRETER POUR SI PEU.
  135. END IF
  136. PT1COU = PT0COU
  137. D1COU = D0COU
  138. *
  139. * APPEL PROCEDURE INTERNE:
  140. PT0COU = PT2COU
  141. X0COU = X2COU
  142. Y0COU = Y2COU
  143. IF (IDIM .EQ. 3) Z0COU = Z2COU
  144. D0COU = D2COU
  145. * ASSIGN 205 TO IRTURN
  146. irturn=205
  147. GOTO 500
  148. 205 CONTINUE
  149. * RETOUR DE PROCEDURE INTERNE.
  150. IF (PT2COU .NE. 0 .AND. PT2COU .NE. PT0COU) THEN
  151. IF (LI2COU .EQ. 0) THEN
  152. CALL ERREUR (296)
  153. ELSE
  154. CALL ERREUR (298)
  155. END IF
  156. * IL N'Y A PAS LIEU DE S'ARRETER POUR SI PEU.
  157. END IF
  158. PT2COU = PT0COU
  159. D2COU = D0COU
  160. *
  161. * LES EXTREMITES ETANT MAINTENANT BIEN DEFINIES, ON APPELLE LE
  162. * SOUS-PROGRAMME DE MAILLAGE.
  163. *
  164. CALL COURB2 (MCOURB, LIGNE)
  165. IF (IERR .NE. 0) RETURN
  166. *
  167. * SI DES LIGNES ONT ETE DONNEES AU LIEU DE POINTS EXTREMES,
  168. * L'OBJET RESULTAT N'EST PAS CE QUI VIENT D'ETRE CREE MAIS LA
  169. * REUNION DES ANCIENNES LIGNES ET DE CE QUI VIENT D'ETRE CREE:
  170. *
  171. IF (LI1COU .NE. 0) THEN
  172. LI0COU = LI1COU
  173. ltelq=.false.
  174. CALL FUSE (LI0COU,LIGNE, IP,ltelq)
  175. IF (IERR .NE. 0) RETURN
  176. LIGNE = IP
  177. END IF
  178. IF (LI2COU .NE. 0) THEN
  179. LI0COU = LI2COU
  180. ltelq=.false.
  181. CALL FUSE (LIGNE,LI0COU, IP,ltelq)
  182. IF (IERR .NE. 0) RETURN
  183. LIGNE = IP
  184. END IF
  185. *
  186. IF (IIMPI .EQ. 342) THEN
  187. IDIMP1 = IDIM + 1
  188. DO 400 IB=1,XCOOR(/1),IDIMP1
  189. IB2 = IB / IDIMP1 + 1
  190. WRITE (IOIMP,'(1X,I5,3(1X,G12.5))') IB2,XCOOR(IB)
  191. & ,XCOOR(IB+1),XCOOR(IB+IDIM)
  192. 400 CONTINUE
  193. * END DO
  194. END IF
  195. *
  196. RETURN
  197. *
  198. * ***********************
  199. * * PROCEDURE INTERNE *
  200. * ***********************
  201. *
  202. * PARAMETRES:
  203. *
  204. * PT0COU (E) POINT EXTREME PROPOSE.
  205. * (S) POINT EXTREME FINALEMENT RETENU.
  206. * X0COU (E) )
  207. * Y0COU (E) )) COORDONNEES DU VERITABLE POINT EXTREME.
  208. * Z0COU (E) )
  209. * D0COU E/S DENSITE ASSOCIEE (LARGEUR DE MAILLE).
  210. * MCOORD (E) SEGMENT ACTIF.
  211. * (S) CE SEGMENT EST EVENTUELLEMENT ETENDU.
  212. *
  213. 500 CONTINUE
  214. *
  215. IF (PT0COU .NE. 0) THEN
  216. IPD = (PT0COU - 1) * (IDIM + 1)
  217. X0DONN = XCOOR(IPD+1)
  218. Y0DONN = XCOOR(IPD+2)
  219. IF (IDIM .EQ. 3) THEN
  220. Z0DONN = XCOOR(IPD+3)
  221. DIST = SQRT((X0COU-X0DONN)**2 + (Y0COU-Y0DONN)**2
  222. & + (Z0COU-Z0DONN)**2)
  223. ELSE
  224. DIST = SQRT((X0COU-X0DONN)**2 + (Y0COU-Y0DONN)**2)
  225. END IF
  226. IF (D0COU .EQ. 0.) THEN
  227. IPD = PT0COU * (IDIM + 1)
  228. D0DONN = XCOOR(IPD)
  229. PETIT = D0DONN * 0.1
  230. ELSE
  231. PETIT = D0COU * 0.1
  232. END IF
  233. NOXTRM = DIST.GT.PETIT
  234. ELSE
  235. NOXTRM = .TRUE.
  236. END IF
  237. *
  238. IF (NOXTRM) THEN
  239. * UN POINT EXTREME NON ACCEPTABLE A ETE FOURNI OU BIEN AUCUN
  240. * POINT N'A ETE FOURNI.
  241. * CREATION D'UN NOUVEAU POINT POUR L'EXTREMITE:
  242. IF (D0COU .EQ. 0.) THEN
  243. D0COU = DENSIT
  244. END IF
  245. CALL CREPO2 (X0COU,Y0COU,Z0COU,D0COU, PT0COU)
  246. IF (IERR .NE. 0) RETURN
  247. ELSE IF (D0COU .EQ. 0.) THEN
  248. * POINT IMPOSE CORRECT ET PAS DE DENSITE IMPOSEE
  249. * --> ON PREND CELLE DU POINT IMPOSE:
  250. D0COU = D0DONN
  251. * ELSE
  252. * SI POINT IMPOSE CORRECT ET DENSITE FOURNIE, RIEN A FAIRE.
  253. END IF
  254. *
  255. if (irturn.eq.105) goto 105
  256. if (irturn.eq.205) goto 205
  257. call erreur(5)
  258. *
  259. END
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  
  273.  

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