Télécharger rf2far.eso

Retour à la liste

Numérotation des lignes :

rf2far
  1. C RF2FAR SOURCE CHAT 06/03/29 21:31:22 5360
  2. SUBROUTINE RF2FAR(NN,INTER, NINTER,
  3. > ITRNOE,NBNMAX,ITRTRI,NBCMAX,
  4. > NOETRI,NBE,COORD,
  5. > ITVL,NTIMAX,RTVL,NTRMAX,iarr)
  6. C *****************************************************************
  7. C OBJET : FORCE LE MAILLAGE A RESPECTER UNE ARETE
  8. C
  9. C EN ENTREE:
  10. C NN() : LES INDICES DES NOEUDS DE L'ARETE
  11. C INTER : TABLEAU DES ELEMENTS INTERSECTANTS NN()
  12. C NINTER : NBRE D'ELEMENTS DE INTER
  13. C AU MINIMUM = 8 * NINTER + 10
  14. C AU MAXIMUM = (NBR MAX D'ELEMENTS EN 1 NOEUD + 1) *
  15. C (NUMERO MAXI DES NOEUDS DES ELEMENTS DE INTER)
  16. C
  17. C ITVL : TABLEAU DE TRAVAIL (ENTIERS)
  18. C NTIMAX : TAILLE DU TABLEAU ITVL
  19. C RTVL : TABLEAU DE TRAVAIL (REELS)
  20. C NTRMAX : TAILLE DU TABLEAU RTVL
  21. C
  22. C EN SORTIE: LE MAILLAGE MODIFIE SI NECESSAIRE.
  23. C iarr : 0 SI OK
  24. C -1 SI LES DONNEES SONT ERRONEES
  25. C NN(1) OU NN(2) N'APPARTIENNT PAS AUX ELEMENTS DE INTER
  26. C -2 SI ITVL EST TROP PETIT
  27. C REMARQUE : ATTENTION LES MAILLES DE INTER SONT RENUMEROTEE DE
  28. C 1 A CARD(INTER), ITRNOE,ITRTRI...SONT MODIFIES !!!
  29. C *****************************************************************
  30. IMPLICIT INTEGER(I-N)
  31. INTEGER NN(*),INTER(*),NINTER,ITRNOE(*),NBNMAX
  32. INTEGER ITRTRI(*),NBCMAX,NOETRI(*),NBE
  33. INTEGER ITVL(*),NTIMAX,NTRMAX,iarr
  34. REAL*8 COORD(*), RTVL(*)
  35. C on enleve l'external TC
  36. C REAL*8 TRRILF
  37. C EXTERNAL TRRILF
  38. INTEGER IDE,I,NBN,NBC,NBIFR,NBIFR1,IND,IFR
  39. INTEGER NIFMAX
  40. INTEGER IT,IF,IT1,J, NOEUD, IFR2, NBCOL, NOEMAX
  41. INTEGER IPOLY,NBPP,IPOLY1,NBPP1,IPOLY2,NBPP2
  42. INTEGER INOE,ITRI,ITRAV,NBTRAV
  43. INTEGER NBFNOE, N, ISOMP, NBSOMP, NCC
  44. INTEGER ITRIP1, ITRIP2, ITI, ITR, NTIMX, NTRMX
  45. REAL*8 QTMIN1, QTMIN2
  46. C
  47. IDE = 2
  48. iarr = 0
  49. IF(NTIMAX.LT.(8*NINTER+10))THEN
  50. iarr = -2
  51. GO TO 999
  52. ENDIF
  53. C ====================================================
  54. C --- 1. COMPRESSION DU MAILLAGE ET CALCUL DE LA FRONTIERE
  55. C ====================================================
  56. C
  57. C ITVL = | IFR |
  58. C 2*NBIFR
  59. C
  60. CALL ENSTRI(INTER,NINTER)
  61. NOEMAX = 1
  62. CALL NUCOMP(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,
  63. > NOEMAX,NBE,INTER,NINTER,iarr)
  64. IF( iarr .NE. 0 )THEN
  65. CALL DSERRE(1,iarr,'RF2FAR',' APPEL NUCOMP')
  66. GOTO 999
  67. ENDIF
  68. C
  69. IND = 1
  70. IFR = 1
  71. NBIFR = 0
  72. NIFMAX = NTIMAX
  73. CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER,
  74. > ITVL(IFR),NBIFR,NIFMAX,iarr)
  75. C
  76. C PRINT *,' FRONTIERE '
  77. C PRINT *,' ',((ITVL((I-1)*2+IFR-1+J),J=1,2),I=1,NBIFR)
  78. IF( iarr .NE. 0 )THEN
  79. CALL DSERRE(1,iarr,'RF2FAR',' APPEL TMAFRT')
  80. GOTO 999
  81. ENDIF
  82. C =========================================
  83. C --- 2. CREATION DES 2 POLYGONES A TRIANGULER. -----
  84. C =========================================
  85. C ITVL = | IFR | INOE | ITRI | IPOLY
  86. C 2*NBIFR NBN*NBIFR NBC*NBIFR
  87. C
  88. NBN = 2
  89. NBC = 2
  90. NBIFR = NINTER + 2
  91. C
  92. C --- 2.1 CREATION DU MAILLAGE LINEIQUE ---
  93. C ----------------------------------
  94. C LE NOMBRE DE PARAMETRES DE SFRCRE A CHANGE ??? O.STAB 07.95
  95. C > ITRTRI,NBCMAX,NOETRI,NBE,ITVL(ITRAV),NBTRAV,
  96. C
  97. INOE = ( 2 * NBIFR ) + 1
  98. ITRI = ( NBN * NBIFR ) + INOE
  99. ITRAV = ( NBC * NBIFR ) + ITRI
  100. C --- ECONOMIE DE FNOETRI --
  101. NBTRAV = (NBC + 1) * NBIFR
  102. NBFNOE = 0
  103. C WRITE(6,*)'APPEL SFRCRE'
  104. CALL SFRCRE(IDE,ITVL(IFR),NBIFR,ITRNOE,NBNMAX,
  105. > ITVL(ITRAV),NBTRAV,
  106. > ITVL(INOE),NBN,ITVL(ITRI),NBC,NBIFR,
  107. > ITVL(1),NBFNOE,NCC,iarr)
  108. C PRINT *,' MAILLAGE FRONTIERE '
  109. C PRINT *,' ',((ITVL((I-1)*2+INOE-1+J),J=1,2),I=1,NBIFR)
  110. IF( iarr .NE. 0 )THEN
  111. CALL DSERRE(1,iarr,'RF2FAR',' APPEL SFRCRE')
  112. GOTO 999
  113. ENDIF
  114. C
  115. C ---- 2.2 FRONTIERE EXTERIEURE ---------
  116. C --------------------------
  117. NBIFR1 = 0
  118. DO 30 I=1,NBIFR
  119. IT = ITVL((I-1)*2+IFR)
  120. IF = ITVL((I-1)*2+IFR+1)
  121. IT1 = ITRTRI((IT-1)*NBCMAX+IF)
  122. IF( IT1.NE.0 )THEN
  123. DO 10 J=1,NBCMAX
  124. IF( ITRTRI((IT1-1)*NBCMAX+J).EQ.IT )GO TO 20
  125. 10 CONTINUE
  126. iarr = -1
  127. GO TO 999
  128. 20 NBIFR1 = NBIFR1 + 1
  129. ITVL((NBIFR1-1)*2+IFR) = IT1
  130. ITVL((NBIFR1-1)*2+IFR+1) = J
  131. ENDIF
  132. 30 CONTINUE
  133. C PRINT *,' FRONTIERE EXTERIEUR '
  134. C PRINT *,' ',((ITVL((I-1)*2+IFR+J-1),J=1,2),I=1,NBIFR1)
  135. C
  136. C ---- DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ----
  137. C MODIF O.STAB 18.08.95 DEPLACE APRES LE CALCUL
  138. C => PERMET UN RETOUR EN ARRIERE EN CAS D'ERREUR
  139. C
  140. C N = 3
  141. C NBSOMP = 0
  142. C ISOMP = 1
  143. C DO 40 I=1,NINTER
  144. C CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
  145. C > NBFNOE,I,N,ITVL(ISOMP),NBSOMP,iarr)
  146. C IF( iarr .NE. 0 )THEN
  147. C 40 CONTINUE
  148. C
  149. C --- 2.3 CONSTRUCTION DU POLYGONE ---
  150. C -----------------------------
  151. C BUG1 : IPOLY = ITRI + ( NBC * NBIFR ) + 1
  152. C REMPLACE PAR :
  153. IPOLY = (6* NBIFR) + MAX(1,NBIFR-4)
  154. C PRINT *,' APPEL ARTOPL '
  155. CALL ARTOPL(ITVL(INOE),2,ITVL(ITRI),2,
  156. > ITVL(IPOLY),NBPP)
  157. C PRINT *,' POLYGONE RESULTANT '
  158. C PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1))
  159. C PRINT *,' ORIGINE, EXTREMITE = ',NN(1),NN(2)
  160. IF( NBPP .LE. 3 )THEN
  161. iarr = -1
  162. CALL DSERRE(1,iarr,'RF2FAR',
  163. > ' POLYGONE A MOINS DE 4 COTES')
  164. GOTO 999
  165. ENDIF
  166. C
  167. C
  168. C --- 2.4 DECOUPAGE DU POLYGONE ---
  169. C ---------------------------
  170. C ITVL = | IFR | XXXXX | IPOLY1 | IPOLY2 | IPOLY
  171. C 2*NBIFR NINTER * 3 NBIFR NBIFR NBIFR
  172. C
  173. C ON STOQUE D'ABORD LA FRONTIERE PUIS LA TRIANGULATION
  174. C PUIS ENFIN LES POLYGONES
  175. C
  176. IPOLY1 = (2 * NBIFR) + (NINTER * 3 ) + 1
  177. C IPOLY1 CONTIENT AU MAX NBPP COTES (NBPP = NBIFR)
  178. C IPOLY2 = IPOLY1 + NBPP - 1
  179. IPOLY2 = IPOLY1 + NBIFR - 1
  180. C DANS LE PIRE CAS C'EST IPOLY2 QUI CONTIENT NBPP COTES
  181. C PRINT *,' APPEL SPLIPL '
  182. C PRINT *,'IPOLY1,IPOLY2,IPOLY = ',IPOLY1,IPOLY2,IPOLY
  183. CALL SPLIPL(ITVL(IPOLY),NBPP,NN,ITVL(IPOLY1),NBPP1,
  184. > ITVL(IPOLY2),NBPP2,iarr)
  185. IF(iarr.NE.0)THEN
  186. C PRINT *,' POLYGONE RESULTANT '
  187. C PRINT *,' ',(ITVL(IPOLY+I),I=0,(NBPP-1))
  188. C PRINT *,' POLYGONE 1 '
  189. C PRINT *,' ',(ITVL(IPOLY1+I),I=0,(NBPP1-1))
  190. C PRINT *,' POLYGONE 2 '
  191. C PRINT *,' ',(ITVL(IPOLY2+I),I=0,(NBPP2-1))
  192. CALL DSERRE(1,iarr,'RF2FAR',' APPEL SPLIPL')
  193. GOTO 999
  194. ENDIF
  195. C
  196. C ===========================
  197. C -------- 3. TRIANGULATION DU TROU ------------------
  198. C ===========================
  199. C ITVL = |NBIFR| ITRIP1 | ITRIP2 | IPOLY1 | IPOLY2 |
  200. C NINTER * 3 NBIFR NBIFR
  201. C
  202. ITRIP1 = ( 2 * NBIFR ) + 1
  203. ITRIP2 = ( 3 *(NBPP1-2) ) + ITRIP1
  204. ITR = 1
  205. NTRMX = NTRMAX
  206. ITI = IPOLY2 + NBIFR
  207. NTIMX = NTIMAX - ITI
  208. C
  209. C PRINT *,' PREMIER APPEL TRPLS2 '
  210. CALL TRPLS2(COORD,ITVL(IPOLY1),NBPP1,
  211. > ITVL(ITI),NTIMX,RTVL(ITR),NTRMX,
  212. C > ITVL(ITRIP1),TRRILF,QTMIN1,iarr) modif TC esxternal
  213. > ITVL(ITRIP1),QTMIN1,iarr)
  214. IF(iarr.NE.0)THEN
  215. CALL DSERRE(1,iarr,'RF2FAR',' PREMIER APPEL TRPLS2')
  216. GOTO 999
  217. ENDIF
  218. C
  219. C PRINT *,' DEUXIEME APPEL TRPLS2 '
  220. CALL TRPLS2(COORD,ITVL(IPOLY2),NBPP2,
  221. > ITVL(ITI),NTIMX,RTVL(ITR),NTRMX,
  222. C > ITVL(ITRIP2),TRRILF,QTMIN2,iarr) modif TC external
  223. > ITVL(ITRIP2),QTMIN2,iarr)
  224. IF(iarr.NE.0)THEN
  225. CALL DSERRE(1,iarr,'RF2FAR',' DEUXIEME APPEL TRPLS2')
  226. GOTO 999
  227. ENDIF
  228. C PRINT *,'QUALITE T1 QUALITE T2 '
  229. C PRINT '(F7.6,F7.6)',QTMIN1,QTMIN2
  230. C
  231. C =======================================================
  232. C ---- 4. DESTRUCTION DES MAILLES SANS MISE A JOUR DE NOETRI ----
  233. C =======================================================
  234. N = 3
  235. NBSOMP = 0
  236. ISOMP = 1
  237. C PRINT *,' APPEL SMADET '
  238. DO 50 I=1,NINTER
  239. CALL SMADET(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBE,NOETRI,
  240. > NBFNOE,I,N,ITVL(ISOMP),NBSOMP,iarr)
  241. IF( iarr .NE. 0 )THEN
  242. CALL DSERRE(1,iarr,'RF2FAR',' APPEL SMADET')
  243. GOTO 999
  244. ENDIF
  245. 50 CONTINUE
  246. C =================================
  247. C --- 5. CREATION DU NOUVEAU MAILLAGE ---
  248. C =================================
  249. NBFNOE = 0
  250. C --- ON LIBERE LES IPOLYS ---
  251. ITRAV = IPOLY1
  252. C PRINT *,' APPEL SMACRE '
  253. NBTRAV = NTIMAX - ITRAV + 1
  254. CALL SMACRE(IDE,ITVL(ITRIP1),NINTER,0,
  255. > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NOETRI,NBFNOE,
  256. > ITVL(ITRAV),NBTRAV,iarr)
  257. IF( iarr .NE. 0 )THEN
  258. CALL DSERRE(1,iarr,'RF2FAR',' APPEL SMACRE')
  259. GOTO 999
  260. ENDIF
  261. C --- POUR LE DEBUG -------
  262. C PRINT *,'TABLEAU DES NOEUDS '
  263. C PRINT *,((ITRNOE((I-1)*NBNMAX+J),J=1,NBNMAX),I=1,NINTER)
  264. C PRINT *,'TABLEAU DES VOISINS '
  265. C PRINT *,((ITRTRI((I-1)*NBCMAX+J),J=1,NBCMAX),I=1,NINTER)
  266. C
  267. C --- COLLAGE DES FRONTIERES ---
  268. C
  269. IND = 1
  270. C --- ON LIBERE LA TRIANGULATION ---
  271. IFR2 = ITRIP1
  272. NIFMAX = NTIMAX - ITRIP1
  273. C PRINT *,' APPEL TMAFRT '
  274. CALL TMAFRT(IDE,ITRNOE,NBNMAX,ITRTRI,NBCMAX,IND,NINTER,
  275. > ITVL(IFR2),NBIFR,NIFMAX,iarr)
  276. IF( iarr .NE. 0 )THEN
  277. CALL DSERRE(1,iarr,'RF2FAR',' APPEL TMAFRT')
  278. GOTO 999
  279. ENDIF
  280. C
  281. C --- MISE A JOUR DE ITRTRI -----------------
  282. C
  283. C PRINT *,' APPEL S2GLAR '
  284. CALL S2GLAR(ITVL(IFR),NBIFR1,ITVL(IFR2),NBIFR,
  285. > ITRNOE,NBNMAX,ITRTRI,NBCMAX,NBCOL)
  286. C
  287. C --- MISE A JOUR DE NOETRI -----------------
  288. C
  289. DO 90 I=1,NINTER
  290. DO 80 J=1,NBNMAX
  291. NOEUD = ITRNOE((I-1)*NBNMAX+J)
  292. IF( NOEUD .NE. 0 )NOETRI(NOEUD)=I
  293. 80 CONTINUE
  294. 90 CONTINUE
  295. 999 END
  296.  
  297.  
  298.  
  299.  

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