Télécharger transf.eso

Retour à la liste

Numérotation des lignes :

  1. C TRANSF SOURCE PV 18/06/18 21:15:42 9860
  2. C CE SOUS PROGRAMME MAILLE A L'INTERIEUR D'UN CONTOUR FERME
  3. C IL EST TIRE DE COCO MAIS UN PEU SIMPLIFIE L'ARCHITECTURE
  4. C S'Y PRETANT MIEUX
  5. C DECEMBRE 1982 : PRISE EN COMPTE DE LA NATURE DES CONTOURS
  6. C (INTERNE OU EXTERNE)
  7. C TEST SI CERTAINS SEGMENTS CREES COUPENT UN CONTOUR
  8. C FEVRIER 1983 ==> QUADRANGLES
  9. C
  10. SUBROUTINE TRANSF(NFI,NFMAX,MAI,MAIMAX,ITOUR,X,MAXPTS,NUM,
  11. # NBNN,NBELEM,NUMELG,NUMNP,XAUX,NUMINI,ICLE,QUAL,INAT,IREGU,IMOYE,
  12. # XMOY,NBMN,IRECHA,ichp)
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8 (A-H,O-Z)
  15. INTEGER NUANC
  16. DIMENSION NFI(*),MAI(*),X(3,*),XAUX(2,*),NUM(NBNN,*),INAT(*)
  17.  
  18. -INC PPARAM
  19. -INC CCOPTIO
  20. -INC CCREEL
  21. NUANC=0
  22. MAXELE=NBELEM
  23. NUMELG=0
  24. NUMNP=MAI(ITOUR+1)
  25. NUMINI=NUMNP+1
  26. IZERO=0
  27. IN=MAI(1)+1
  28. LEMIN=NUMELG+1
  29. KT36=ITOUR
  30. LONG=MAI(ITOUR+1)
  31. C ON FORCE LA DENSITE DE CHAQUE POINT A SA VALEUR REELLE CONNUE
  32. DO 300 IT=1,ITOUR
  33. IT1=MAI(IT-1+1)+1
  34. IT2=MAI(IT+1)
  35. DO 300 I=IT1,IT2
  36. ISUIV=I+1
  37. IF (ISUIV.GT.IT2) ISUIV=IT1
  38. IALTE=0
  39. IPREC=I-1
  40. IF (IPREC.LT.IT1) IPREC=IT2
  41. SUIV=SQRT((X(1,NFI(ISUIV))-X(1,NFI(I)))**2+
  42. # (X(2,NFI(ISUIV))-X(2,NFI(I)))**2)
  43. SPRE=SQRT((X(1,NFI(IPREC))-X(1,NFI(I)))**2+
  44. # (X(2,NFI(IPREC))-X(2,NFI(I)))**2)
  45. 300 X(3,NFI(I))=SQRT(SUIV*SPRE)
  46. IPARC=0
  47. 200 IPARC=IPARC+1
  48. C VERIFICATION QUE TOUT EST CORRECT : LA SURFACE EST POSITIVE
  49. SURF=0.D0
  50. DO 3500 IT=1,ITOUR
  51. IT1=MAI(IT-1+1)+1
  52. IT2=MAI(IT+1)
  53. SURF1=0.D0
  54. DO 3501 I=IT1,IT2
  55. ISUIV=I+1
  56. IF (ISUIV.GT.IT2) ISUIV=IT1
  57. SURF1=SURF1+X(1,NFI(I))*X(2,NFI(ISUIV))-X(2,NFI(I))*X(1,NFI(ISUIV
  58. # ))
  59. 3501 CONTINUE
  60. INAT(IT)=1
  61. IF (SURF1.LT.0.D0) INAT(IT)=-1
  62. IF (SURF1.EQ.0.D0) GOTO 1500
  63. SURF=SURF+SURF1
  64. 3500 CONTINUE
  65. IF (SURF.LT.0.D0) GOTO 1500
  66. C FABRICATION DES NOEUDS DECALES
  67. IF=MAI(ITOUR+1)
  68. IF (IMOYE.NE.0) GOTO 935
  69. XMOY=0
  70. DO 310 I=IN,IF
  71. 310 XMOY=XMOY+LOG(X(3,NFI(I)))
  72. XMOY=EXP(XMOY/(IF-IN+1))
  73. IF (IIMPI.EQ.1) WRITE (IOIMP,8877) XMOY
  74. 8877 FORMAT(' LA VALEUR MOYENNE DE LA MAILLE RETENUE EST: ',G12.5)
  75. 935 CONTINUE
  76. XMOMA=0
  77. XMOMI=XGRAND
  78. DO 3001 I=IN,IF
  79. XMOMI=MIN(XMOMI,X(3,NFI(I)))
  80. XMOMA=MAX(XMOMA,X(3,NFI(I)))
  81. 3001 CONTINUE
  82. COS=1.d0/REAL(IREGU)
  83. DO 311 I=IN,IF
  84. * modif pour prendre en compte un chpt de densite
  85. if (ichp.ne.0) xmoy=denchp(ichp,x(1,nfi(i)),x(2,nfi(i)))
  86. XSU=XMOY+XMOY*COS
  87. XIN=XMOY-MIN(XMOMI,XMOY*COS)
  88. IF (X(3,NFI(I)).GT.XIN) GOTO 920
  89. X(3,NFI(I))=X(3,NFI(I))+MIN(COS*X(3,NFI(I)),XMOMI)
  90. GOTO 311
  91. 920 IF (X(3,NFI(I)).LT.XSU) GOTO 921
  92. X(3,NFI(I))=X(3,NFI(I))*(1.d0-COS)
  93. GOTO 311
  94. 921 X(3,NFI(I))=XMOY
  95. 311 CONTINUE
  96. C ON METS UN ELEMENT DANT TOUS LES COINS (JUSQU'A 100 DEG)
  97. 360 CONTINUE
  98. IT=0
  99. 251 IT=IT+1
  100. IF (IT.GT.ITOUR) GOTO 253
  101. IDI=MAI(IT-1+1)+1
  102. IFI=MAI(IT+1)
  103. I=IDI-1
  104. IAUX=0
  105. VECTOR=-XGRAND
  106. 250 I=I+1
  107. IAUX=IAUX+1
  108. IF (IAUX.GT.IFI-IDI+1) GOTO 1200
  109. IF (I.GT.IFI) I=IDI
  110. IF (I.EQ.IDI.AND.IIMPI.EQ.1) WRITE (IOIMP,9878) IT,IDI,IFI,IAUX
  111. 9878 FORMAT (' IT,IDI,IFI,IAUX ',4I5)
  112. IPRES=I-1
  113. IF (IPRES.LT.IDI) IPRES=IFI
  114. ISUIV=I+1
  115. IF (ISUIV.GT.IFI) ISUIV=IDI
  116. IF (NFI(IPRES).EQ.NFI(ISUIV)) GOTO 250
  117. SCAL=(X(1,NFI(IPRES))-X(1,NFI(I)))*(X(1,NFI(ISUIV))-X(1,NFI(I)))+
  118. # (X(2,NFI(IPRES))-X(2,NFI(I)))*(X(2,NFI(ISUIV))-X(2,NFI(I)))
  119. VECT=(X(1,NFI(IPRES))-X(1,NFI(I)))*(X(2,NFI(ISUIV))-X(2,NFI(I)))-
  120. # (X(2,NFI(IPRES))-X(2,NFI(I)))*(X(1,NFI(ISUIV))-X(1,NFI(I)))
  121. IF (VECT.EQ.0.D0.AND.SCAL.EQ.0.D0) GOTO 1500
  122. ANG=ATAN2(VECT,SCAL)
  123. * write (6,*) 'atan2 - 4 ',ang,vect,vector,iaux,ifi,idi
  124. IF (ANG.LT.-2.34D0.OR.ANG.GE.1.D-5) GOTO 250
  125. IF (ANG.LT.-1.6D0.AND.NBNN.EQ.3) GOTO 250
  126. IF (VECT.LE.VECTOR*0.999999d0.AND.IAUX.NE.IFI-IDI+1.AND.NBNN.EQ.3)
  127. > GOTO 250
  128. * write (6,*) ' apres atan2 -4 '
  129. LL1=NFI(IPRES)
  130. LL2=NFI(ISUIV)
  131. C ON VA TESTER SI LE SEGMENT EN COUPE UN AUTRE
  132. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  133. IF (IRECL.NE.0.AND.IFI-IDI.GT.2) GOTO 250
  134. VECTSA=VECT
  135. IF (IAUX.EQ.IFI-IDI+1.OR.NBNN.EQ.4) GOTO 390
  136. VECTOR=VECT
  137. IAUX=0
  138. GOTO 250
  139. 390 CONTINUE
  140. C POUR LES QUA4 ON ESSAYE DE COMPLETER LE TRIANGLE EN UN QUADRANGLE
  141. IF (NBNN.EQ.3) GOTO 6100
  142. IF (IFI-IDI.LE.2) GOTO 6100
  143. IF (ANG.GT.-0.8D0) GOTO 6100
  144. IAV=IPRES-1
  145. IF (IAV.LT.IDI) IAV=IFI
  146. C CALCUL DE L'ANGLE
  147. SCAL=(X(1,NFI(IAV))-X(1,NFI(IPRES)))*(X(1,NFI(I))-X(1,NFI(IPRES)))
  148. # +(X(2,NFI(IAV))-X(2,NFI(IPRES)))*(X(2,NFI(I))-X(2,NFI(IPRES)))
  149. VECT=(X(1,NFI(IAV))-X(1,NFI(IPRES)))*(X(2,NFI(I))-X(2,NFI(IPRES)))
  150. # -(X(2,NFI(IAV))-X(2,NFI(IPRES)))*(X(1,NFI(I))-X(1,NFI(IPRES)))
  151. IF (VECT.EQ.0D0.AND.SCAL.EQ.0.D0) GOTO 1500
  152. ANGA=ATAN2(-VECT,SCAL)
  153. * write (6,*) 'atan2 - 5 ',anga
  154. IF (ANGA.GT.0.8D0.OR.ANGA.LE.1.d-5) GOTO 6006
  155. I=IAV
  156. GOTO 250
  157. 6006 IF (ANGA.GT.2.34D0.OR.ANGA.LT.0.D0) GOTO 6010
  158. LL1=NFI(IAV)
  159. LL2=NFI(ISUIV)
  160. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  161. IF (IRECL.NE.0) GOTO 6010
  162. XLA=(X(1,NFI(IAV))-X(1,NFI(ISUIV)))**2
  163. # +(X(2,NFI(IAV))-X(2,NFI(ISUIV)))**2
  164. XCOMP=X(3,NFI(I))*X(3,NFI(IPRES))
  165. IF (XLA.LT.0.333D0*XCOMP.OR.XLA.GT.3.D0*XCOMP) GOTO 6010
  166. C SI 5 NOEUDS SUR LE CONTOUR TEST SUPPLEMENTAIRE
  167. IF (IFI-IDI.NE.4) GOTO 6008
  168. ICINQ=IAV-1
  169. IF (ICINQ.LT.IDI) ICINQ=IFI
  170. SUC=(X(1,NFI(IAV))-X(1,NFI(ICINQ)))*(X(2,NFI(ISUIV))-X(2,NFI(ICINQ
  171. #)))-(X(2,NFI(IAV))-X(2,NFI(ICINQ)))*(X(1,NFI(ISUIV))-X(1,NFI(ICINQ
  172. #)))
  173. IF (SUC.GT.XLA*XLA/3.D0) GOTO 6008
  174. GOTO 6010
  175. 6008 NUMELG=NUMELG+1
  176. IF (NUMELG.GE.MAXELE) GOTO 1500
  177. NUM(1,NUMELG)=NFI(IAV)
  178. NUM(2,NUMELG)=NFI(IPRES)
  179. NUM(3,NUMELG)=NFI(I)
  180. NUM(4,NUMELG)=NFI(ISUIV)
  181. IF=IF-1
  182. IFI=IFI-2
  183. X(3,NFI(IAV))=SQRT(X(3,NFI(IAV))*X(3,NFI(IPRES)))
  184. X(3,NFI(ISUIV))=SQRT(X(3,NFI(I))*X(3,NFI(ISUIV)))
  185. DO 6002 J=I,IF
  186. NFI(J)=NFI(J+1)
  187. 6002 CONTINUE
  188. IF=IF-1
  189. IF (IPRES.GT.I) IPRES=IPRES-1
  190. DO 6003 J=IPRES,IF
  191. 6003 NFI(J)=NFI(J+1)
  192. DO 6004 J=IT,ITOUR
  193. 6004 MAI(J+1)=MAI(J+1)-2
  194. I=IAV-1
  195. IDI=MAI(IT-1+1)+1
  196. IFI=MAI(IT+1)
  197. VECTOR=-XGRAND
  198. IAUX=0
  199. IF (IFI-IDI.NE.1) GOTO 250
  200. ITOUR=ITOUR-1
  201. IF (ITOUR.EQ.0) GOTO 1600
  202. DO 6005 I=IT,ITOUR
  203. INAT(I)=INAT(I+1)
  204. 6005 MAI(I+1)=MAI(I+1+1)-2
  205. IF=MAI(ITOUR+1)
  206. ID=MAI(IT-1+1)+1
  207. DO 6007 I=ID,IF
  208. 6007 NFI(I)=NFI(I+2)
  209. IT=IT-1
  210. GOTO 251
  211. C CALCUL DE L'ANGLE
  212. 6010 IAP=ISUIV+1
  213. IF (IAP.GT.IFI) IAP=IDI
  214. SCAL=(X(1,NFI(I))-X(1,NFI(ISUIV)))*(X(1,NFI(IAP))-X(1,NFI(ISUIV)))
  215. # +(X(2,NFI(I))-X(2,NFI(ISUIV)))*(X(2,NFI(IAP))-X(2,NFI(ISUIV)))
  216. VECT=(X(1,NFI(I))-X(1,NFI(ISUIV)))*(X(2,NFI(IAP))-X(2,NFI(ISUIV)))
  217. # -(X(2,NFI(I))-X(2,NFI(ISUIV)))*(X(1,NFI(IAP))-X(1,NFI(ISUIV)))
  218. IF (VECT.EQ.0D0.AND.SCAL.EQ.0.D0) GOTO 1500
  219. ANGA=ATAN2(-VECT,SCAL)
  220. * write (6,*) ' atan2 - 1 ',anga
  221. IF (ANGA.GE.0.D0.AND.ANGA.LT.0.8D0) GOTO 250
  222. IF (ANGA.GT.2.34D0.OR.ANGA.LT.0.D0) GOTO 6020
  223. LL1=NFI(IAP)
  224. LL2=NFI(IPRES)
  225. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  226. IF (IRECL.NE.0) GOTO 6020
  227. XLA=(X(1,NFI(IAP))-X(1,NFI(IPRES)))**2
  228. # +(X(2,NFI(IAP))-X(2,NFI(IPRES)))**2
  229. XCOMP=X(3,NFI(I))*X(3,NFI(ISUIV))
  230. IF (XLA.LT.0.333D0*XCOMP.OR.XLA.GT.3.D0*XCOMP) GOTO 6020
  231. C SI 5 NOEUDS SUR LE CONTOUR TEST SUPPLEMENTAIRE
  232. IF (IFI-IDI.NE.4) GOTO 6018
  233. ICINQ=IPRES-1
  234. IF (ICINQ.LT.IDI) ICINQ=IFI
  235. SUC=(X(1,NFI(IPRES))-X(1,NFI(ICINQ)))*(X(2,NFI(IAP))-X(2,NFI(ICINQ
  236. #)))-(X(2,NFI(IPRES))-X(2,NFI(ICINQ)))*(X(1,NFI(IAP))-X(1,NFI(ICINQ
  237. #)))
  238. IF (SUC.GT.XLA*XLA/3.D0) GOTO 6018
  239. GOTO 6020
  240. 6018 NUMELG=NUMELG+1
  241. IF (NUMELG.GE.MAXELE) GOTO 1500
  242. NUM(1,NUMELG)=NFI(IPRES)
  243. NUM(2,NUMELG)=NFI(I)
  244. NUM(3,NUMELG)=NFI(ISUIV)
  245. NUM(4,NUMELG)=NFI(IAP)
  246. IFI=IFI-2
  247. IF=IF-1
  248. X(3,NFI(IAP))=SQRT(X(3,NFI(IAP))*X(3,NFI(ISUIV)))
  249. X(3,NFI(IPRES))=SQRT(X(3,NFI(IPRES))*X(3,NFI(I)))
  250. DO 6012 J=I,IF
  251. 6012 NFI(J)=NFI(J+1)
  252. IF=IF-1
  253. IF (ISUIV.GT.I) ISUIV=ISUIV-1
  254. DO 6013 J=ISUIV,IF
  255. 6013 NFI(J)=NFI(J+1)
  256. DO 6014 J=IT,ITOUR
  257. 6014 MAI(J+1)=MAI(J+1)-2
  258. I=IAV
  259. IDI=MAI(IT-1+1)+1
  260. IFI=MAI(IT+1)
  261. VECTOR=-XGRAND
  262. IAUX=0
  263. IF (IFI-IDI.NE.1) GOTO 250
  264. ITOUR=ITOUR-1
  265. IF (ITOUR.EQ.0) GOTO 1600
  266. DO 6015 I=IT,ITOUR
  267. INAT(I)=INAT(I+1)
  268. 6015 MAI(I+1)=MAI(I+1+1)-2
  269. IF=MAI(ITOUR+1)
  270. ID=MAI(IT-1+1)+1
  271. DO 6017 I=ID,IF
  272. 6017 NFI(I)=NFI(I+2)
  273. IT=IT-1
  274. GOTO 251
  275. 6020 CONTINUE
  276. C ON TENTE DE FAIRE UN LOSANGE
  277. NTENT=NUMNP+1
  278. IF (NTENT.GT.MAXPTS) GOTO 1500
  279. X(1,NTENT)=X(1,NFI(IPRES))+X(1,NFI(ISUIV))-X(1,NFI(I))
  280. X(2,NTENT)=X(2,NFI(IPRES))+X(2,NFI(ISUIV))-X(2,NFI(I))
  281. LL1=NFI(I)
  282. LL2=NTENT
  283. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  284. * write (6,*) ' transa - irecl 1 ',irecl
  285. IF (IRECL.NE.0) GOTO 6100
  286. LL1=NFI(ISUIV)
  287. 1040 IF (IRECL.NE.0) GOTO 6100
  288. C VERIFICATION DES DISTANCES
  289. XLA=(X(1,NTENT)-X(1,NFI(IPRES)))**2
  290. # +(X(2,NTENT)-X(2,NFI(IPRES)))**2
  291. XCOMP=X(3,NFI(IPRES))*X(3,NFI(I))
  292. IF (XLA.LT.0.333D0*XCOMP.OR.XLA.GT.3.D0*XCOMP) GOTO 6100
  293. XLB=(X(1,NTENT)-X(1,NFI(ISUIV)))**2
  294. # +(X(2,NTENT)-X(2,NFI(ISUIV)))**2
  295. XCOMP=X(3,NFI(ISUIV))*X(3,NFI(I))
  296. IF (XLB.LT.0.333D0*XCOMP.OR.XLB.GT.3.D0*XCOMP) GOTO 6100
  297. C VERIFICATION : RECHERCHE DU POINT LE PLUS PRES
  298. INATIT=INAT(IT)
  299. XL=XGRAND
  300. IP=0
  301. ITP=0
  302. DO 6030 ITT=1,ITOUR
  303. IF (INATIT.EQ.1.AND.INAT(ITT).EQ.1.AND.IT.NE.ITT) GOTO 6030
  304. IDIA=MAI(ITT-1+1)+1
  305. IFIA=MAI(ITT+1)
  306. DO 6031 IA=IDIA,IFIA
  307. IF (NFI(IA).EQ.NFI(I)) GOTO 6031
  308. IF (NFI(IA).EQ.NFI(IPRES)) GOTO 6031
  309. IF (NFI(IA).EQ.NFI(ISUIV)) GOTO 6031
  310. DIS=(X(1,NTENT)-X(1,NFI(IA)))**2+(X(2,NTENT)-X(2,NFI(IA)))**2
  311. IF (DIS.GT.XL) GOTO 6031
  312. XL=DIS
  313. IP=IA
  314. ITP=ITT
  315. 6031 CONTINUE
  316. 6030 CONTINUE
  317. * write (6,*) ' ip le plus proche ',ip
  318. C ITP IP EST LE POINT LE PLUS PROCHE
  319. IF (XL.LT.0.3333D0*(XLA*XLB)**0.25D0*X(3,NFI(IP))) GOTO 6100
  320. IF (XL.EQ.0.D0) GOTO 6100
  321. IDIP=MAI(ITP+1-1)+1
  322. IFIP=MAI(ITP+1)
  323. IPA=IP-1
  324. IF (IPA.LT.IDIP) IPA=IFIP
  325. IPS=IP+1
  326. IF (IPS.GT.IFIP) IPS=IDIP
  327. SCALA=(X(1,NFI(IP))-X(1,NTENT))*(X(1,NFI(IPA))-X(1,NTENT))
  328. # +(X(2,NFI(IP))-X(2,NTENT))*(X(2,NFI(IPA))-X(2,NTENT))
  329. VECTA=(X(1,NFI(IP ))-X(1,NTENT))*(X(2,NFI(IPA))-X(2,NTENT))
  330. # -(X(2,NFI(IP ))-X(2,NTENT))*(X(1,NFI(IPA))-X(1,NTENT))
  331. IF (SCALA.EQ.0.D0.AND.VECTA.EQ.0.D0) GOTO 1500
  332. ANGA=ATAN2(-VECTA,SCALA)
  333. * write (6,*) 'atan2 - 2 ',anga
  334.  
  335. IF (ANGA.GT.2.34D0.OR.ANGA.LT.0.D0) GOTO 6100
  336. SCALS=(X(1,NFI(IPS))-X(1,NTENT))*(X(1,NFI(IP ))-X(1,NTENT))
  337. # +(X(2,NFI(IPS))-X(2,NTENT))*(X(2,NFI(IP ))-X(2,NTENT))
  338. VECTS=(X(1,NFI(IPS))-X(1,NTENT))*(X(2,NFI(IP ))-X(2,NTENT))
  339. # -(X(2,NFI(IPS))-X(2,NTENT))*(X(1,NFI(IP ))-X(1,NTENT))
  340. IF (SCALS.EQ.0.D0.AND.VECTS.EQ.0.D0) GOTO 1500
  341. ANGS=ATAN2(-VECTS,SCALS)
  342. * write (6,*) 'atan2 - 3 ',angs
  343. IF (ANGS.GT.2.34D0.OR.ANGS.LE.1.d-5) GOTO 6100
  344. C OK ON Y VA
  345. NUMELG=NUMELG+1
  346. NUM(1,NUMELG)=NFI(IPRES)
  347. NUM(2,NUMELG)=NFI(I)
  348. NUM(3,NUMELG)=NFI(ISUIV)
  349. NUM(4,NUMELG)=NTENT
  350. NUMNP=NUMNP+1
  351. IF (X(3,NFI(I)).GT.XIN) GOTO 6060
  352. X(3,NTENT)=X(3,NFI(I))+MIN(COS*X(3,NFI(I)),XMOMI)
  353. GOTO 6062
  354. 6060 IF (X(3,NFI(I)).LT.XSU) GOTO 6061
  355. X(3,NTENT)=X(3,NFI(I))*(1.D0-COS)
  356. GOTO 6062
  357. 6061 X(3,NTENT)=XMOY
  358. 6062 CONTINUE
  359. NFI(I)=NUMNP
  360. VECTOR=-XGRAND
  361. IAUX=0
  362. I=IPRES
  363. GOTO 250
  364. 6100 CONTINUE
  365. IF(ANG.LT.-1.9D0) GOTO 250
  366. C SI 4 NOEUDS SUR LE CONTOUR TEST SUPPLEMENTAIRE
  367. IF (IFI-IDI.NE.3) GOTO 6101
  368. IQUAT=IPRES-1
  369. IF (IQUAT.LT.IDI) IQUAT=IFI
  370. SUC=(X(1,NFI(IPRES))-X(1,NFI(IQUAT)))*(X(2,NFI(ISUIV))-
  371. # X(2,NFI(IQUAT)))-(X(2,NFI(IPRES))-X(2,NFI(IQUAT)))*
  372. #(X(1,NFI(ISUIV))-X(1,NFI(IQUAT)))
  373. IF (SUC.GT.-VECTSA/5.D0) GOTO 6101
  374. IAA=I
  375. I=ISUIV
  376. ISUIV=IQUAT
  377. IQUAT=IPRES
  378. IPRES=IAA
  379. GOTO 6101
  380. 6101 IAX=IAUX
  381. IAUX=0
  382. VECTOR=-XGRAND
  383. C3=(X(1,NFI(ISUIV))-X(1,NFI(IPRES)))**2+(X(2,NFI(ISUIV))-
  384. # X(2,NFI(IPRES)))**2
  385. C3=SQRT(C3)
  386. IF(C3.GT.1.5d0*X(3,NFI(I)).AND.MAI(IT+1)-MAI(IT-1+1).NE.3)
  387. > GOTO 261
  388. NUMELG=NUMELG+1
  389. IF (NUMELG.GT.MAXELE) GOTO 1500
  390. NUM(1,NUMELG)=NFI(IPRES)
  391. NUM(2,NUMELG)=NFI(I)
  392. NUM(3,NUMELG)=NFI(ISUIV)
  393. IF (NBNN.EQ.4) NUM(4,NUMELG)=0
  394. IFI=IFI-1
  395. IF=IF-1
  396. X(3,NFI(IPRES))=SQRT(X(3,NFI(IPRES))*X(3,NFI(I)))
  397. X(3,NFI(ISUIV))=SQRT(X(3,NFI(ISUIV))*X(3,NFI(I)))
  398. DO 255 J=I,IF
  399. NFI(J)=NFI(J+1)
  400. 255 CONTINUE
  401. DO 256 J=IT,ITOUR
  402. 256 MAI(J+1)=MAI(J+1)-1
  403. I=IPRES-1
  404. IDI=MAI(IT-1+1)+1
  405. IFI=MAI(IT+1)
  406. IF (MAI(IT+1)-MAI(IT-1+1).NE.2) GOTO 250
  407. ID=MAI(IT-1+1)+1
  408. DO 257 J=ID,IF
  409. NFI(J)=NFI(J+2)
  410. 257 CONTINUE
  411. 244 CONTINUE
  412. ITOUR=ITOUR-1
  413. IF (ITOUR.EQ.0) GOTO 1600
  414. DO 258 I=IT,ITOUR
  415. INAT(I)=INAT(I+1)
  416. 258 MAI(I+1)=MAI(I+1+1)-2
  417. IF=MAI(ITOUR+1)
  418. IT=IT-1
  419. GOTO 251
  420. 261 NUMNP=NUMNP+1
  421. IF (NUMNP.GE.MAXPTS) GOTO 1500
  422. A=X(3,NFI(IPRES))+X(3,NFI(ISUIV))
  423. B=X(3,NFI(ISUIV))/A
  424. C=X(3,NFI(IPRES))/A
  425. X(1,NUMNP)=C*X(1,NFI(ISUIV))+B*X(1,NFI(IPRES))
  426. X(2,NUMNP)=C*X(2,NFI(ISUIV))+B*X(2,NFI(IPRES))
  427. IF (X(3,NFI(I)).GT.XIN) GOTO 6070
  428. X(3,NUMNP)=X(3,NFI(I))+MIN(COS*X(3,NFI(I)),XMOMI)
  429. GOTO 6072
  430. 6070 IF (X(3,NFI(I)).LT.XSU) GOTO 6071
  431. X(3,NUMNP)=X(3,NFI(I))*(1.d0-COS)
  432. GOTO 6072
  433. 6071 X(3,NUMNP)=XMOY
  434. 6072 CONTINUE
  435. NUANC=NUANC+1
  436. NUMELG=NUMELG+1
  437. IF (NUMELG+1.GE.MAXELE) GOTO 1500
  438. NUM(1,NUMELG)=NFI(IPRES)
  439. NUM(2,NUMELG)=NFI(I)
  440. NUM(3,NUMELG)=NUMNP
  441. IF (NBNN.EQ.4) NUM(4,NUMELG)=0
  442. NUMELG=NUMELG+1
  443. NUM(1,NUMELG)=NFI(I)
  444. NUM(2,NUMELG)=NFI(ISUIV)
  445. NUM(3,NUMELG)=NUMNP
  446. IF (NBNN.EQ.4) NUM(4,NUMELG)=0
  447. NFI(I)=NUMNP
  448. I=IPRES-1
  449. GOTO 250
  450. 1200 CONTINUE
  451. IDI=MAI(IT-1+1)+1
  452. IFI=MAI(IT+1)
  453. DO 1 I=IDI,IFI
  454. IPRES=I-1
  455. IF (IPRES.LT.IDI) IPRES=IFI
  456. ISUIV=I+1
  457. IF (ISUIV.GT.IFI) ISUIV=IDI
  458. XL1=SQRT((X(1,NFI(IPRES))-X(1,NFI(I)))**2+
  459. # (X(2,NFI(IPRES))-X(2,NFI(I)))**2)
  460. XL2=SQRT((X(1,NFI(ISUIV))-X(1,NFI(I)))**2+
  461. # (X(2,NFI(ISUIV))-X(2,NFI(I)))**2)
  462. XDIR=XL2*(X(2,NFI(IPRES))-X(2,NFI(I)))+XL1*(X(2,NFI(I))-X(2,
  463. # NFI(ISUIV)))
  464. YDIR=XL1*(X(1,NFI(ISUIV))-X(1,NFI(I)))+XL2*(X(1,NFI(I))-X(1,
  465. # NFI(IPRES)))
  466. SDIR=SQRT(XDIR**2+YDIR**2)
  467. IF (SDIR.EQ.0.D0) XDIR=XL2*(X(2,NFI(IPRES))-X(2,NFI(I)))
  468. IF (SDIR.EQ.0.D0) YDIR=-(XL2*(X(1,NFI(IPRES))-X(1,NFI(I))))
  469. IF (SDIR.EQ.0.D0) SDIR=SQRT(XDIR**2+YDIR**2)
  470. RAP=X(3,NFI(I))/SDIR
  471. IF (NBNN.EQ.3) RAP=RAP*0.85D0
  472. XAUX(1,I)=X(1,NFI(I))+RAP*XDIR
  473. XAUX(2,I)=X(2,NFI(I))+RAP*YDIR
  474. 1 CONTINUE
  475. C TESTS POUR LA SEPARATION OU LA FUSION DES CONTOURS
  476. ITO=0
  477. IP1=0
  478. IP2=0
  479. RAP=10
  480. IDI=MAI(IT-1+1)+1
  481. IFI=MAI(IT+1)
  482. IF (IFI-IDI.LE.3) GOTO 373
  483. IFIP=IFI-3
  484. IDIP=IDI
  485. DO 351 I=IDIP,IFIP
  486. IG=I+3
  487. IPRES=I-1
  488. IF (IPRES.LT.IDI) IPRES=IFI
  489. ISUIV=I+1
  490. IF (ISUIV.GT.IFI) ISUIV=IDI
  491. IFTA=IFI-MAX(0,IDIP+2-I)
  492. IF (IG.GT.IFTA) GOTO 351
  493. DO 352 J=IG,IFTA
  494. JSUIV=J+1
  495. JPRES=J-1
  496. IF (JPRES.LT.IDI) JPRES=IFI
  497. IF (JSUIV.GT.IFI) JSUIV=IDI
  498. IF (NFI(I).EQ.NFI(J)) GOTO 352
  499. IF (NFI(IPRES).EQ.NFI(J)) GOTO 352
  500. IF (NFI(I+1).EQ.NFI(J)) GOTO 352
  501. IF (NFI(I).EQ.NFI(JSUIV)) GOTO 352
  502. IF (NFI(I).EQ.NFI(JPRES)) GOTO 352
  503. DI=SQRT((X(1,NFI(I))-X(1,NFI(J)))**2+(X(2,NFI(I))-X(2,NFI(J)))**2)
  504. XRAP=DI/MAX(X(3,NFI(I)),X(3,NFI(J)))
  505. IF (XRAP.EQ.0.D0) GOTO 1500
  506. C REGLAGE POSSIBLE: A PARTIR DE QUAND COUPER EN 2 LE SEGMENT GENERE
  507. IF (XRAP.GT.1.415D0) GOTO 352
  508. IF (XRAP.GT.RAP*0.99999D0) GOTO 352
  509. C VERIFICATION QUE LES POINTS SE FONT FACE
  510. SCAL=(XAUX(1,I)-X(1,NFI(I)))*(XAUX(1,J)-X(1,NFI(J)))
  511. # +(XAUX(2,I)-X(2,NFI(I)))*(XAUX(2,J)-X(2,NFI(J)))
  512. C REGLAGE POUR DETECTER SI LES POINTS SE FONT FACE LA FUSION MARCHE
  513. C DE LA MEME FACON
  514. IF (SCAL.GE.0.D0) GOTO 352
  515. SCAL=(XAUX(1,I)-X(1,NFI(I)))*(X(1,NFI(J))-X(1,NFI(I)))
  516. # +(XAUX(2,I)-X(2,NFI(I)))*(X(2,NFI(J))-X(2,NFI(I)))
  517. IF (SCAL.LT.0.D0) GOTO 352
  518. SCAL=(XAUX(1,J)-X(1,NFI(J)))*(X(1,NFI(I))-X(1,NFI(J)))
  519. # +(XAUX(2,J)-X(2,NFI(J)))*(X(2,NFI(I))-X(2,NFI(J)))
  520. IF (SCAL.LT.0.D0) GOTO 352
  521. C ON INTERDIT DE COUPER UN COUTOUR EXTERIEUR EN UN EXTERIEUR +
  522. C UN INTERIEUR OU UN INTERIEUR EN DEUX INTERIEUR
  523. NATINI=INAT(IT)
  524. SURF1=0.D0
  525. SURF2=0.D0
  526. LPRES=IFI
  527. DO 1001 L=IDI,IFI
  528. SU=X(1,NFI(LPRES))*X(2,NFI(L))-X(2,NFI(LPRES))*X(1,NFI(L))
  529. IF (L.LE.I.OR.LPRES.GE.J) SURF1=SURF1+SU
  530. IF (L.GT.I.AND.LPRES.LT.J) SURF2=SURF2+SU
  531. LPRES=L
  532. 1001 CONTINUE
  533. SU=X(1,NFI(I))*X(2,NFI(J))-X(2,NFI(I))*X(1,NFI(J))
  534. SURF1=SURF1+SU
  535. SURF2=SURF2-SU
  536. IF (NATINI.GE.0.AND.SURF1*SURF2.LT.0.D0) GOTO 352
  537. IF (NATINI.LT.0.AND.SURF1.LT.0.D0.AND.SURF2.LT.0.D0) GOTO 352
  538. C TEST SI LE SEGMENT CANDIDAT EN COUPE UN AUTRE
  539. LL1=NFI(I)
  540. LL2=NFI(J)
  541. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  542. IF (IRECL.NE.0) GOTO 352
  543. LL3=NFI(IPRES)
  544. LL4=NFI(ISUIV)
  545. CALL TRANSB(X,IRECL,LL1,LL2,LL3,LL4)
  546. IF (IRECL.NE.0) GOTO 352
  547. LL1=NFI(J)
  548. LL2=NFI(I)
  549. LL3=NFI(JPRES)
  550. LL4=NFI(JSUIV)
  551. CALL TRANSB(X,IRECL,LL1,LL2,LL3,LL4)
  552. IF (IRECL.NE.0) GOTO 352
  553. 380 CONTINUE
  554. C OK
  555. RAP=XRAP
  556. ITO=IT
  557. IP1=I
  558. IP2=J
  559. SUK1=SURF1
  560. SUK2=SURF2
  561. 352 CONTINUE
  562. 351 CONTINUE
  563. IF (ITO.EQ.0) GOTO 353
  564. IF (IIMPI.EQ.1) WRITE (IOIMP,5566) NFI(IP1),NFI(IP2)
  565. 5566 FORMAT (' SEPARATION DES CONTOURS ',2I6)
  566. IDI=MAI(ITO-1+1)+1
  567. IFI=MAI(ITO+1)
  568. IDEB=MAI(ITOUR+1)+1
  569. ITOUR=ITOUR+1
  570. IF (ITOUR.GE.MAIMAX) GOTO 1500
  571. IF (IDEB.GE.NFMAX) GOTO 1500
  572. NFI(IDEB)=NFI(IP1)
  573. IDEB=IDEB+1
  574. IF (IDEB.GE.NFMAX) GOTO 1500
  575. IP=IP2
  576. 355 IF (IP.GT.IFI) IP=IDI
  577. IF (IP.EQ.IP1) GOTO 354
  578. NFI(IDEB)=NFI(IP)
  579. IDEB=IDEB+1
  580. IF (IDEB.GE.NFMAX) GOTO 1500
  581. IP=IP+1
  582. GOTO 355
  583. 354 IDEB=IDEB-1
  584. MAI(ITOUR+1)=IDEB
  585. INAT(ITOUR)=1
  586. IF (SUK1.LT.0.D0) INAT(ITOUR)=-1
  587. ITOUR=ITOUR+1
  588. IF (ITOUR.GE.MAIMAX) GOTO 1500
  589. IDEB=IDEB+1
  590. IF (IDEB.GE.NFMAX) GOTO 1500
  591. IP=IP1
  592. 357 IF (IP.GT.IP2) GOTO 356
  593. NFI(IDEB)=NFI(IP)
  594. IP=IP+1
  595. IDEB=IDEB+1
  596. IF (IDEB.GE.NFMAX) GOTO 1500
  597. GOTO 357
  598. 356 CONTINUE
  599. IDEB=IDEB-1
  600. MAI(ITOUR+1)=IDEB
  601. INAT(ITOUR)=1
  602. IF (SUK2.LT.0.D0) INAT(ITOUR)=-1
  603. C SUPPRESSION DE ITO
  604. IDEC=MAI(ITO+1)-MAI(ITO-1+1)
  605. ID=MAI(ITO-1+1)+1
  606. ITOUR=ITOUR-1
  607. DO 358 I=ITO,ITOUR
  608. INAT(I)=INAT(I+1)
  609. 358 MAI(I+1)=MAI(I+1+1)-IDEC
  610. IF=MAI(ITOUR+1)
  611. DO 359 I=ID,IF
  612. 359 NFI(I)=NFI(I+IDEC)
  613. IT=IT-1
  614. GOTO 251
  615. 353 CONTINUE
  616. C DEUXIEME TEST PORTANT SUR LES XAUX PARCOUR DECALE TRAITEMENT SIMILAIR
  617. ITO=0
  618. IP1=0
  619. IP2=0
  620. RAP=10
  621. IDI=MAI(IT-1+1)+1
  622. IFI=MAI(IT+1)
  623. IFIP=IFI-2
  624. IDIP=IDI
  625. DO 371 I=IDIP,IFIP
  626. IG=I+2
  627. IFTA=IFI-MAX(0,IDIP+1-I)
  628. IF (IG.GT.IFTA) GOTO 371
  629. DO 372 J=IG,IFTA
  630. IF (I.EQ.IDI.AND.J.EQ.IFI) GOTO 372
  631. DI=SQRT((XAUX(1,I)-XAUX(1,J))**2+(XAUX(2,I)-XAUX(2,J))**2)
  632. XRAP=DI/MAX(X(3,NFI(I)),X(3,NFI(J)))
  633. IF (XRAP.GT.0.707D0) GOTO 372
  634. C ON VERIFIE QUE LES POINTS SONT EN FACE
  635. SCAL=(XAUX(1,I)-X(1,NFI(I)))*(XAUX(1,J)-X(1,NFI(J)))
  636. # +(XAUX(2,I)-X(2,NFI(I)))*(XAUX(2,J)-X(2,NFI(J)))
  637. IF (SCAL.GE.0D0) GOTO 372
  638. XRAP=-SCAL/(X(3,NFI(I))*X(3,NFI(J)))
  639. IF (XRAP.GT.RAP*0.99999D0) GOTO 372
  640. NATINI=INAT(IT)
  641. SURF1=0.D0
  642. SURF2=0.D0
  643. LPRES=IFI
  644. DO 1002 L=IDI,IFI
  645. SU=X(1,NFI(LPRES))*X(2,NFI(L))-X(2,NFI(LPRES))*X(1,NFI(L))
  646. IF (L.LE.I.OR.LPRES.GE.J) SURF1=SURF1+SU
  647. IF (L.GT.I.AND.LPRES.LT.J) SURF2=SURF2+SU
  648. LPRES=L
  649. 1002 CONTINUE
  650. SU=X(1,NFI(I))*X(2,NFI(J))-X(2,NFI(I))*X(1,NFI(J))
  651. SURF1=SURF1+SU
  652. SURF2=SURF2-SU
  653. IF (NATINI.GE.0.AND.SURF1*SURF2.LT.0.D0) GOTO 372
  654. IF (NATINI.LT.0.AND.SURF1.LT.0.D0.AND.SURF2.LT.0.D0) GOTO 372
  655. C TEST SI LES DEUX SEGMENTS CANDITATS EN COUPENT UN AUTRE
  656. IF (NUMNP+1.GE.MAXPTS) GOTO 1500
  657. X(1,NUMNP+1)=(X(3,NFI(J))*XAUX(1,I)+X(3,NFI(I))*XAUX(1,J))/
  658. # (X(3,NFI(I))+X(3,NFI(J)))
  659. X(2,NUMNP+1)=(X(3,NFI(J))*XAUX(2,I)+X(3,NFI(I))*XAUX(2,J))/
  660. # (X(3,NFI(I))+X(3,NFI(J)))
  661. LL1=NFI(I)
  662. LL2=NUMNP+1
  663. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  664. IF (IRECL.NE.0) GOTO 372
  665. IPRES=I-1
  666. IF (IPRES.LT.IDI) IPRES=IFI
  667. ISUIV=I+1
  668. IF (ISUIV.GT.IFI) ISUIV=IDI
  669. LL3=NFI(IPRES)
  670. LL4=NFI(ISUIV)
  671. CALL TRANSB(X,IRECL,LL1,LL2,LL3,LL4)
  672. IF (IRECL.NE.0) GOTO 372
  673. LL1=NUMNP+1
  674. LL2=NFI(J)
  675. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  676. IF (IRECL.NE.0) GOTO 372
  677. JPRES=J-1
  678. IF (JPRES.LT.IDI) JPRES=IFI
  679. JSUIV=J+1
  680. IF (JSUIV.GT.IFI) JSUIV=IDI
  681. LL1=NFI(J)
  682. LL2=NUMNP+1
  683. LL3=NFI(JPRES)
  684. LL4=NFI(JSUIV)
  685. CALL TRANSB(X,IRECL,LL1,LL2,LL3,LL4)
  686. IF (IRECL.NE.0) GOTO 372
  687. RAP=XRAP
  688. ITO=IT
  689. IP1=I
  690. IP2=J
  691. SUK1=SURF1
  692. SUK2=SURF2
  693. 372 CONTINUE
  694. 371 CONTINUE
  695. IF (ITO.EQ.0) GOTO 373
  696. IF (IIMPI.EQ.1) WRITE (IOIMP,7788) NFI(IP1),NFI(IP2)
  697. 7788 FORMAT (' SEPARATION 2EME TYPE ',2I6)
  698. C ON RAJOUTE UN POINT
  699. NUMNP=NUMNP+1
  700. X(1,NUMNP)=(X(3,NFI(IP2))*XAUX(1,IP1)+X(3,NFI(IP1))*XAUX(1,IP2))/
  701. # (X(3,NFI(IP1))+X(3,NFI(IP2)))
  702. X(2,NUMNP)=(X(3,NFI(IP2))*XAUX(2,IP1)+X(3,NFI(IP1))*XAUX(2,IP2))/
  703. # (X(3,NFI(IP1))+X(3,NFI(IP2)))
  704. IDI=MAI(ITO-1+1)+1
  705. IFI=MAI(ITO+1)
  706. IDEB=MAI(ITOUR+1)+1
  707. ITOUR=ITOUR+1
  708. IF (ITOUR.GE.MAIMAX) GOTO 1500
  709. IF (IDEB.GE.NFMAX) GOTO 1500
  710. NFI(IDEB)=NFI(IP1)
  711. IDEB=IDEB+1
  712. IF (IDEB.GE.NFMAX) GOTO 1500
  713. NFI(IDEB)=NUMNP
  714. X(3,NFI(IDEB))=SQRT(X(3,NFI(IP1))*X(3,NFI(IP2)))
  715. IDEB=IDEB+1
  716. IP=IP2
  717. 375 IF (IP.GT.IFI) IP=IDI
  718. IF (IP.EQ.IP1) GOTO 374
  719. IF (IDEB.GE.NFMAX) GOTO 1500
  720. NFI(IDEB)=NFI(IP)
  721. IDEB=IDEB+1
  722. IP=IP+1
  723. GOTO 375
  724. 374 IDEB=IDEB-1
  725. MAI(ITOUR+1)=IDEB
  726. INAT(ITOUR)=1
  727. IF (SUK1.LT.0.D0) INAT(ITOUR)=-1
  728. ITOUR=ITOUR+1
  729. IDEB=IDEB+1
  730. IF (ITOUR.GE.MAIMAX.OR.IDEB.GE.NFMAX) GOTO 1500
  731. IP=IP1
  732. 377 IF (IP.GT.IP2) GOTO 376
  733. NFI(IDEB)=NFI(IP)
  734. IP=IP+1
  735. IDEB=IDEB+1
  736. IF (IDEB.GE.NFMAX) GOTO 1500
  737. GOTO 377
  738. 376 CONTINUE
  739. NFI(IDEB)=NUMNP
  740. X(3,NFI(IDEB))=SQRT(X(3,NFI(IP1))*X(3,NFI(IP2)))
  741. MAI(ITOUR+1)=IDEB
  742. INAT(ITOUR)=1
  743. IF (SUK2.LT.0.D0) INAT(ITOUR)=-1
  744. C SUPPRESSION DE ITO
  745. IDEC=MAI(ITO+1)-MAI(ITO-1+1)
  746. ID=MAI(ITO-1+1)+1
  747. ITOUR=ITOUR-1
  748. DO 378 I=ITO,ITOUR
  749. INAT(I)=INAT(I+1)
  750. 378 MAI(I+1)=MAI(I+1+1)-IDEC
  751. IF=MAI(ITOUR+1)
  752. DO 379 I=ID,IF
  753. 379 NFI(I)=NFI(I+IDEC)
  754. IT=IT-1
  755. GOTO 251
  756. 373 CONTINUE
  757. GOTO 251
  758. 253 CONTINUE
  759. C POUR LE CAS DES MAILLAGES AVEC TROUS RECOLLEMENT EVENTUEL DES CONTOUR
  760. IOPT=0
  761. ITO1=0
  762. ITO2=0
  763. IP1=0
  764. IP2=0
  765. RAP=10
  766. ITOUI=ITOUR-1
  767. IF (ITOUI.EQ.0) GOTO 520
  768. DO 500 IT1=1,ITOUI
  769. IDI1=MAI(IT1-1+1)+1
  770. IFI1=MAI(IT1+1)
  771. ITD=IT1+1
  772. DO 502 IT2=ITD,ITOUR
  773. IF (IT2.EQ.IT1) GOTO 502
  774. C IMPOSSIBLE DE FUSIONNER DEUX CONTOURS EXTERIEURS
  775. IF (INAT(IT1).EQ.1.AND.INAT(IT2).EQ.1) GOTO 502
  776. IDI2=MAI(IT2-1+1)+1
  777. IFI2=MAI(IT2+1)
  778. DO 503 I2=IDI2,IFI2
  779. IPRES2=I2-1
  780. IF (IPRES2.LT.IDI2) IPRES2=IFI2
  781. ISUIV2=I2+1
  782. IF (ISUIV2.GT.IFI2) ISUIV2=IDI2
  783. DO 501 I1=IDI1,IFI1
  784. IPRES1=I1-1
  785. IF (IPRES1.LT.IDI1) IPRES1=IFI1
  786. ISUIV1=I1+1
  787. IF (ISUIV1.GT.IFI1) ISUIV1=IDI1
  788. IF (NFI(I1).EQ.NFI(I2)) GOTO 501
  789. IF (NFI(IPRES1).EQ.NFI(I2)) GOTO 501
  790. IF (NFI(ISUIV1).EQ.NFI(I2)) GOTO 501
  791. IF (NFI(I1).EQ.NFI(IPRES2)) GOTO 501
  792. IF (NFI(I1).EQ.NFI(ISUIV2)) GOTO 501
  793. DI=SQRT((X(1,NFI(I1))-X(1,NFI(I2)))**2+
  794. # (X(2,NFI(I1))-X(2,NFI(I2)))**2)
  795. XRAP=DI/MAX(X(3,NFI(I1)),X(3,NFI(I2)))
  796. IF (XRAP.EQ.0.D0) GOTO 1500
  797. IF (XRAP.GT.1.415D0) GOTO 530
  798. IF (XRAP.GT.RAP*0.99999D0) GOTO 530
  799. C VERIFICATION QUE LES POINTS SE FONT FACE
  800. SCAL=(XAUX(1,I1)-X(1,NFI(I1)))*(XAUX(1,I2)-X(1,NFI(I2)))
  801. # +(XAUX(2,I1)-X(2,NFI(I1)))*(XAUX(2,I2)-X(2,NFI(I2)))
  802. IF (SCAL.GE.0D0) GOTO 530
  803. SCAL=(XAUX(1,I1)-X(1,NFI(I1)))*(X(1,NFI(I2))-X(1,NFI(I1)))
  804. # +(XAUX(2,I1)-X(2,NFI(I1)))*(X(2,NFI(I2))-X(2,NFI(I1)))
  805. IF (SCAL.LT.0.D0) GOTO 530
  806. SCAL=(XAUX(1,I2)-X(1,NFI(I2)))*(X(1,NFI(I1))-X(1,NFI(I2)))
  807. # +(XAUX(2,I2)-X(2,NFI(I2)))*(X(2,NFI(I1))-X(2,NFI(I2)))
  808. IF (SCAL.LT.0.D0) GOTO 530
  809. LL1=NFI(I1)
  810. LL2=NFI(I2)
  811. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  812. IF (IRECL.NE.0) GOTO 501
  813. 381 CONTINUE
  814. RAP=XRAP
  815. ITO1=IT1
  816. ITO2=IT2
  817. IP1=I1
  818. IP2=I2
  819. IOPT=1
  820. GOTO 501
  821. 530 CONTINUE
  822. C DEUXIEME POSSIBILITE
  823. DI=SQRT((XAUX(1,I1)-XAUX(1,I2))**2+(XAUX(2,I1)-XAUX(2,I2))**2)
  824. XRAP=DI/MAX(X(3,NFI(I1)),X(3,NFI(I2)))
  825. IF (XRAP.GT.0.8D0) GOTO 501
  826. IF (XRAP.GT.RAP*0.99999D0) GOTO 501
  827. C ON VERIFIE QUE LES POINTS SONT EN FACE
  828. SCAL=(XAUX(1,I1)-X(1,NFI(I1)))*(XAUX(1,I2)-X(1,NFI(I2)))
  829. # +(XAUX(2,I1)-X(2,NFI(I1)))*(XAUX(2,I2)-X(2,NFI(I2)))
  830. IF (SCAL.GE.0.D0) GOTO 501
  831. LL1=NFI(I1)
  832. LL2=NFI(I2)
  833. CALL TRANSA(NFI,MAI,ITOUR,X,XMOY,IRECL,LL1,LL2,LL3,LL4)
  834. IF (IRECL.NE.0) GOTO 501
  835. LL3=NFI(IPRES1)
  836. LL4=NFI(ISUIV1)
  837. CALL TRANSB(X,IRECL,LL1,LL2,LL3,LL4)
  838. IF (IRECL.NE.0) GOTO 501
  839. LL1=NFI(I2)
  840. LL2=NFI(I1)
  841. LL3=NFI(IPRES2)
  842. LL4=NFI(ISUIV2)
  843. CALL TRANSB(X,IRECL,LL1,LL2,LL3,LL4)
  844. IF (IRECL.NE.0) GOTO 501
  845. RAP=XRAP
  846. ITO1=IT1
  847. ITO2=IT2
  848. IP1=I1
  849. IP2=I2
  850. IOPT=2
  851. 501 CONTINUE
  852. 503 CONTINUE
  853. 502 CONTINUE
  854. 500 CONTINUE
  855. IF (IOPT.EQ.0) GOTO 520
  856. IF (IOPT.EQ.1) GOTO 531
  857. NUMNP=NUMNP+1
  858. IF (NUMNP.GE.MAXPTS) GOTO 1500
  859. X(1,NUMNP)=(X(3,NFI(IP2))*X(1,NFI(IP1))+X(3,NFI(IP1))*
  860. # X(1,NFI(IP2)))/(X(3,NFI(IP1))+X(3,NFI(IP2)))
  861. X(2,NUMNP)=(X(3,NFI(IP2))*X(2,NFI(IP1))+X(3,NFI(IP1))*
  862. # X(2,NFI(IP2)))/(X(3,NFI(IP1))+X(3,NFI(IP2)))
  863. 531 CONTINUE
  864. IF (IIMPI.EQ.1) WRITE (IOIMP,6655) ITO1,ITO2,NFI(IP1),NFI(IP2)
  865. 6655 FORMAT(' FUSION DES CONTOURS ',4I6)
  866. IDI1=MAI(ITO1-1+1)+1
  867. IFI1=MAI(ITO1+1)
  868. IDI2=MAI(ITO2-1+1)+1
  869. IFI2=MAI(ITO2+1)
  870. IDEB=MAI(ITOUR+1)+1
  871. ITOUR=ITOUR+1
  872. IF (ITOUR.GE.MAIMAX.OR.IDEB.GE.NFMAX) GOTO 1500
  873. IF (IOPT.EQ.1) GOTO 532
  874. NFI(IDEB)=NUMNP
  875. X(3,NFI(IDEB))=SQRT(X(3,NFI(IP1))*X(3,NFI(IP2)))
  876. IDEB=IDEB+1
  877. IF (IDEB.GE.NFMAX) GOTO1500
  878. 532 NFI(IDEB)=NFI(IP1)
  879. IP=IP1
  880. 505 IP=IP+1
  881. IF (IP.GT.IFI1) IP=IDI1
  882. IF (IP.EQ.IP1) GOTO 506
  883. IDEB=IDEB+1
  884. IF (IDEB.GE.NFMAX) GOTO 1500
  885. NFI(IDEB)=NFI(IP)
  886. GOTO 505
  887. 506 IDEB=IDEB+1
  888. IF (IDEB.GE.NFMAX) GOTO 1500
  889. NFI(IDEB)=NFI(IP1)
  890. IDEB=IDEB+1
  891. IF (IDEB.GE.NFMAX) GOTO 1500
  892. IF (IOPT.EQ.1) GOTO 534
  893. NFI(IDEB)=NUMNP
  894. X(3,NFI(IDEB))=SQRT(X(3,NFI(IP1))*X(3,NFI(IP2)))
  895. IDEB=IDEB+1
  896. IF (IDEB.GE.NFMAX) GOTO 1500
  897. 534 CONTINUE
  898. NFI(IDEB)=NFI(IP2)
  899. IP=IP2
  900. 507 IP=IP+1
  901. IF (IP.GT.IFI2) IP=IDI2
  902. IDEB=IDEB+1
  903. IF (IDEB.GE.NFMAX) GOTO 1500
  904. NFI(IDEB)=NFI(IP)
  905. IF (IP.NE.IP2) GOTO 507
  906. MAI(ITOUR+1)=IDEB
  907. INAT(ITOUR)=1
  908. IF (INAT(ITO1).EQ.-1.AND.INAT(ITO2).EQ.-1) INAT(ITOUR)=-1
  909. C SUPPRESSION DE ITO1 ITO2
  910. IDEC=MAI(ITO1+1)-MAI(ITO1-1+1)
  911. ID=MAI(ITO1-1+1)+1
  912. ITOUR=ITOUR-1
  913. DO 508 I=ITO1,ITOUR
  914. INAT(I)=INAT(I+1)
  915. 508 MAI(I+1)=MAI(I+1+1)-IDEC
  916. IF=MAI(ITOUR+1)
  917. DO 509 I=ID,IF
  918. 509 NFI(I)=NFI(I+IDEC)
  919. ITO2=ITO2-1
  920. IDEC=MAI(ITO2+1)-MAI(ITO2-1+1)
  921. ID=MAI(ITO2-1+1)+1
  922. ITOUR=ITOUR-1
  923. DO 510 I=ITO2,ITOUR
  924. INAT(I)=INAT(I+1)
  925. 510 MAI(I+1)=MAI(I+1+1)-IDEC
  926. IF=MAI(ITOUR+1)
  927. DO 511 I=ID,IF
  928. 511 NFI(I)=NFI(I+IDEC)
  929. GOTO 360
  930. 520 CONTINUE
  931. C REPARTITION DES POINTS SUR LE CONTOUR DECALE
  932. C FABRICATION DES TRIANGLES JOIGNANT LES DEUX CONTOURS
  933. IAJOU=ITOUR
  934. IT=0
  935. 320 IT=IT+1
  936. IAJOU=IAJOU+1
  937. IF (IAJOU.GE.MAIMAX) GOTO 1500
  938. IF (IT.GT.ITOUR) GOTO 321
  939. INAT(IAJOU)=INAT(IT)
  940. IDI=MAI(IT-1+1)+1
  941. IFI=MAI(IT+1)
  942. IAJDI=MAI(IAJOU-1+1)+1
  943. IF (NBNN.EQ.3) GOTO 6300
  944. C POUR LES QUADRANGLES ON UTILISE UN AUTRE PROCEDE DE GENERATION
  945. NUMNP=NUMNP+1
  946. IF (NUMNP.GE.MAXPTS) GOTO 1500
  947. IPREM=NUMNP
  948. X(1,NUMNP)=XAUX(1,IDI)
  949. X(2,NUMNP)=XAUX(2,IDI)
  950. X(3,NUMNP)=X(3,NFI(IDI))
  951. IF (IAJDI.GE.NFMAX) GOTO 1500
  952. NFI(IAJDI)=NUMNP
  953. DO 6301 I=IDI,IFI
  954. ISUIV=I+1
  955. IF (ISUIV.GT.IFI) ISUIV=IDI
  956. XCOMP=X(3,NUMNP)*X(3,NFI(ISUIV))
  957. XLONG=(XAUX(1,ISUIV)-X(1,NUMNP))**2+(XAUX(2,ISUIV)-X(2,NUMNP))**2
  958. IF (XLONG.LT.0.5D0*XCOMP) GOTO 6302
  959. IF (XLONG.GT.2.D0*XCOMP) GOTO 6303
  960. C ON FAIT UN QUADRILATERE
  961. 6320 CONTINUE
  962. NUMELG=NUMELG+1
  963. IF (NUMNP+1.GE.MAXPTS.OR.NUMELG.GE.MAXELE) GOTO 1500
  964. NUM(1,NUMELG)=NFI(I)
  965. NUM(2,NUMELG)=NFI(ISUIV)
  966. NUM(3,NUMELG)=NUMNP+1
  967. NUM(4,NUMELG)=NUMNP
  968. IF (ISUIV.EQ.IDI) GOTO 6312
  969. NUMNP=NUMNP+1
  970. X(1,NUMNP)=XAUX(1,ISUIV)
  971. X(2,NUMNP)=XAUX(2,ISUIV)
  972. X(3,NUMNP)=X(3,NFI(ISUIV))
  973. IAJDI=IAJDI+1
  974. IF (IAJDI.GE.NFMAX) GOTO 1500
  975. NFI(IAJDI)=NUMNP
  976. GOTO 6301
  977. 6312 NUM(3,NUMELG)=IPREM
  978. IF (IPREM.NE.NUMNP) GOTO 6301
  979. NUMELG=NUMELG-1
  980. C LE SEGMENT EST TROP PETIT ==> ON FAIT UN TRIANGLE
  981. 6302 X(1,NUMNP)=0.5D0*(X(1,NUMNP)+XAUX(1,ISUIV))
  982. X(2,NUMNP)=0.5D0*(X(2,NUMNP)+XAUX(2,ISUIV))
  983. X(3,NUMNP)=SQRT(X(3,NUMNP)*X(3,NFI(ISUIV)))
  984. XAUX(1,I)=X(1,NUMNP)
  985. XAUX(2,I)=X(2,NUMNP)
  986. NUMELG=NUMELG+1
  987. IF (NUMELG.GE.MAXELE) GOTO 1500
  988. NUM(1,NUMELG)=NFI(I)
  989. NUM(2,NUMELG)=NFI(ISUIV)
  990. NUM(3,NUMELG)=NUMNP
  991. NUM(4,NUMELG)=0
  992. IF (ISUIV.NE.IDI) GOTO 6301
  993. IF (NUMNP.EQ.IPREM) GOTO 6301
  994. NUMU=NUMELG+1
  995. 6321 NUMU=NUMU-1
  996. IF (NUM(3,NUMU).NE.NUMNP) GOTO 6322
  997. NUM(3,NUMU)=IPREM
  998. C CORRECTION PROBLEME YALA SYST SUR CRAY 06/18/86
  999. IF (NUM(4,NUMU).NE.IPREM+1) GOTO 6321
  1000. C ALORS COUPER NUMU EN 2 TRIANGLES POUR NE PAS AVOIR 2 QUAD SE TOUCHAN
  1001. C PAR TROIS POINTS
  1002. NUMELG=NUMELG+1
  1003. IF (NUMELG.GE.MAXELE) GOTO 1500
  1004. NUM(1,NUMELG)=NUM(4,NUMU)
  1005. NUM(2,NUMELG)=NUM(2,NUMU)
  1006. NUM(3,NUMELG)=NUM(3,NUMU)
  1007. NUM(4,NUMELG)=0
  1008. NUM(3,NUMU)=NUM(4,NUMU)
  1009. NUM(4,NUMU)=0
  1010. 6322 CONTINUE
  1011. X(1,IPREM)=X(1,NUMNP)
  1012. X(2,IPREM)=X(2,NUMNP)
  1013. NUMNP=NUMNP-1
  1014. IAJDI=IAJDI-1
  1015. GOTO 6301
  1016. C LE SEGMENT EST TROP GRAND ==> ON FAIT UN TRIANGLE ET UN QUADRANGLE
  1017. 6303 IALTE=1-IALTE
  1018. IF (NUMNP+2.GE.MAXPTS.OR.NUMELG+2.GE.MAXELE) GOTO 1500
  1019. X(1,NUMNP+1)=0.5D0*(X(1,NUMNP)+XAUX(1,ISUIV))
  1020. X(2,NUMNP+1)=0.5D0*(X(2,NUMNP)+XAUX(2,ISUIV))
  1021. X(3,NUMNP+1)=SQRT(X(3,NUMNP)*X(3,NFI(ISUIV)))
  1022. IAJDI=IAJDI+1
  1023. IF (IAJDI+1.GE.NFMAX) GOTO 1500
  1024. NFI(IAJDI)=NUMNP+1
  1025. X(1,NUMNP+2)=XAUX(1,ISUIV)
  1026. X(2,NUMNP+2)=XAUX(2,ISUIV)
  1027. X(3,NUMNP+2)=X(3,NFI(ISUIV))
  1028. IAJDI=IAJDI+1
  1029. NFI(IAJDI)=NUMNP+2
  1030. NUMELG=NUMELG+1
  1031. NUM(1,NUMELG)=NUMNP+1
  1032. NUM(2,NUMELG)=NUMNP
  1033. NUM(3,NUMELG)=NFI(I)
  1034. NUM(4,NUMELG)=0
  1035. IF (IALTE.EQ.1) NUM(4,NUMELG)=NFI(ISUIV)
  1036. NUMELG=NUMELG+1
  1037. IF (IALTE.NE.1) GOTO 6330
  1038. NUM(1,NUMELG)=NUMNP+1
  1039. NUM(2,NUMELG)=NFI(ISUIV)
  1040. NUM(3,NUMELG)=NUMNP+2
  1041. NUM(4,NUMELG)=0
  1042. GOTO 6331
  1043. 6330 NUM(1,NUMELG)=NFI(I)
  1044. NUM(2,NUMELG)=NFI(ISUIV)
  1045. NUM(3,NUMELG)=NUMNP+2
  1046. NUM(4,NUMELG)=NUMNP+1
  1047. 6331 CONTINUE
  1048. NUMNP=NUMNP+2
  1049. IF (ISUIV.NE.IDI) GOTO 6301
  1050. NUM(3,NUMELG)=IPREM
  1051. NUMNP=NUMNP-1
  1052. IAJDI=IAJDI-1
  1053. GOTO 6301
  1054. 6301 CONTINUE
  1055. GOTO 14
  1056. 6300 CONTINUE
  1057. ICA=IDI
  1058. ICN=ICA
  1059. NUANC=NUMNP
  1060. NUMNP=NUMNP+1
  1061. IF (NUMNP.GE.MAXPTS) GOTO 1500
  1062. X(1,NUMNP)=XAUX(1,ICA)
  1063. X(2,NUMNP)=XAUX(2,ICA)
  1064. NUSAUV=NUMNP
  1065. X(3,NUMNP)=X(3,NFI(ICA))
  1066. IF (IAJDI.GE.NFMAX) GOTO 1500
  1067. NFI(IAJDI)=NUMNP
  1068. DISTR=0.D0
  1069. 2 ICAS=ICA+1
  1070. DISTA=1.D0
  1071. ISAUT=0
  1072. IF (ICAS.GT.IFI) ICAS=IDI
  1073. 21 ICNS=ICN+1
  1074. ISAUT=ISAUT+1
  1075. IF (ICNS.GT.IFI) ICNS=IDI
  1076. IF (ICN.GT.IFI) GOTO 10
  1077. DISCO=X(3,NFI(ICNS))
  1078. DISTT=SQRT((XAUX(1,ICNS)-X(1,NUMNP))**2+(XAUX(2,ICNS)-X(2,NUMNP))
  1079. # **2)
  1080. DISTA=EXP((REAL(ISAUT-1)*LOG(DISTA)+LOG(DISCO))/REAL(ISAUT))
  1081. IF (DISTT.GE.DISTA) GOTO 20
  1082. NUMELG=NUMELG+1
  1083. IF (NUMELG.GT.MAXELE) GOTO 1500
  1084. NUM(1,NUMELG)=NUSAUV
  1085. NUM(2,NUMELG)=NFI(ICN)
  1086. NUM(3,NUMELG)=NFI(ICNS)
  1087. ICN=ICN+1
  1088. GOTO 21
  1089. 20 CONTINUE
  1090. DISTSU=DISTT-DISTA
  1091. DINCR=SQRT((XAUX(1,ICNS)-XAUX(1,ICN))**2+(XAUX(2,ICNS)-XAUX(2,ICN)
  1092. # )**2)
  1093. RAP=MIN(1.D0,DISTSU/DINCR)
  1094. NUPREC=NUSAUV
  1095. NUMNP=NUMNP+1
  1096. IF (NUMNP.GE.MAXPTS) GOTO 1500
  1097. NUSAUV=NUMNP
  1098. IAJDI=IAJDI+1
  1099. IF (IAJDI.GE.NFMAX) GOTO 1500
  1100. X(3,NUMNP)=DISTA
  1101. NFI(IAJDI)=NUMNP
  1102. X(1,NUMNP)=XAUX(1,ICN)*RAP+(1.D0-RAP)*XAUX(1,ICNS)
  1103. X(2,NUMNP)=XAUX(2,ICN)*RAP+(1.D0-RAP)*XAUX(2,ICNS)
  1104. C VERIFICATION QU'ON NE PASSE PAS TROP PRES DES PTS
  1105. C NFI(ICN) ET NFI(ICNS)
  1106. ZRA=((X(1,NUMNP)-X(1,NFI(ICN)))*(X(2,NUMNP-1)-X(2,NFI(ICN)))-(X(2
  1107. # ,NUMNP)-X(2,NFI(ICN)))*(X(1,NUMNP-1)-X(1,NFI(ICN))))/(DISTA**2)
  1108. IF (ZRA.GT.0.4D0) GOTO 2003
  1109. XQ=X(1,NUMNP)
  1110. YQ=X(2,NUMNP)
  1111. X(1,NUMNP)=XQ+(1-ZRA)*(X(2,NUMNP-1)-YQ)
  1112. X(2,NUMNP)=YQ+(1-ZRA)*(XQ-X(1,NUMNP-1))
  1113. 2003 CONTINUE
  1114. IF (ISAUT.EQ.1) GOTO 240
  1115. ICNP=ICN-1
  1116. IF (ICNP.LT.IDI) GOTO 240
  1117. C1=(X(1,NUPREC)-X(1,NFI(ICN)))**2+
  1118. # (X(2,NUPREC)-X(2,NFI(ICN)))**2
  1119. C2=(X(1,NUSAUV)-X(1,NFI(ICNP)))**2+
  1120. # (X(2,NUSAUV)-X(2,NFI(ICNP)))**2
  1121. IF (C1.LE.C2) GOTO 240
  1122. NUM(1,NUMELG)=NUSAUV
  1123. NUM(2,NUMELG)=NUPREC
  1124. NUM(3,NUMELG)=NFI(ICNP)
  1125. NUMELG=NUMELG+1
  1126. IF (NUMELG.GE.MAXELE) GOTO 1500
  1127. NUM(1,NUMELG)=NUSAUV
  1128. NUM(2,NUMELG)=NFI(ICNP)
  1129. NUM(3,NUMELG)=NFI(ICN)
  1130. ICA=ICN
  1131. GOTO 2
  1132. 240 CONTINUE
  1133. NUMELG=NUMELG+1
  1134. IF (NUMELG.GE.MAXELE) GOTO 1500
  1135. NUM(1,NUMELG)=NUSAUV
  1136. NUM(2,NUMELG)=NUPREC
  1137. NUM(3,NUMELG)=NFI(ICN)
  1138. ICA=ICN
  1139. GOTO 2
  1140. 10 CONTINUE
  1141. * CORRECTION PROBLEME VAGHI 5/2/87 1 SEUL POINT INTERNE
  1142. IF (NUSAUV.EQ.NUANC+1) GOTO 14
  1143. C=SQRT((X(1,NUSAUV)-X(1,NUANC+1))**2+(X(2,NUSAUV)-X(2,NUANC+1))
  1144. # **2)
  1145. IF (C.GT.X(3,NFI(IFI))) GOTO 11
  1146. X(1,NUANC+1)=0.5D0*(X(1,NUANC+1)+X(1,NUSAUV))
  1147. X(2,NUANC+1)=0.5D0*(X(2,NUANC+1)+X(2,NUSAUV))
  1148. NUMU=NUMELG+1
  1149. 12 NUMU=NUMU-1
  1150. IF (NUM(1,NUMU).NE.NUSAUV) GOTO 15
  1151. NUM(1,NUMU)=NUANC+1
  1152. GOTO 12
  1153. 15 CONTINUE
  1154. NUMNP=NUMNP-1
  1155. IAJDI=IAJDI-1
  1156. GOTO 14
  1157. 11 NUMELG=NUMELG+1
  1158. IF (NUMELG.GE.MAXELE) GOTO 1500
  1159. NUM(1,NUMELG)=NUANC+1
  1160. NUM(2,NUMELG)=NUMNP
  1161. NUM(3,NUMELG)=NFI(IDI)
  1162. 14 MAI(IAJOU+1)=IAJDI
  1163. IF (MAI(IAJOU+1)-MAI(IAJOU-1+1).LT.3) IAJOU=IAJOU-1
  1164. IF (NUMELG.GE.MAXELE.OR.NUMNP.GE.MAXPTS) GOTO 1500
  1165. GOTO 320
  1166. 321 CONTINUE
  1167. IAJOU=IAJOU-1
  1168. IDEC=MAI(ITOUR+1)-IN+1
  1169. IF=MAI(IAJOU+1)-IDEC
  1170. DO 204 I=IN,IF
  1171. NFI(I)=NFI(I+IDEC)
  1172. 204 CONTINUE
  1173. ITDEC=IAJOU-ITOUR
  1174. DO 202 IT=1,ITDEC
  1175. INAT(IT)=INAT(IT+ITOUR)
  1176. MAI(IT+1)=MAI(IT+ITOUR+1)-IDEC
  1177. 202 CONTINUE
  1178. ITOUR=ITDEC
  1179. IF (ITOUR.EQ.0) GOTO 1600
  1180. IF (NUMNP.GE.MAXPTS.OR.NUMELG.GE.MAXELE) GOTO 1500
  1181. GOTO 200
  1182. 1500 IRECHA=27
  1183. ICLE=0
  1184. RETURN
  1185. 1600 CONTINUE
  1186. LEMAX=NUMELG
  1187. ICLE=2
  1188. NINF=NUMNP
  1189. RETURN
  1190. END
  1191.  
  1192.  
  1193.  
  1194.  
  1195.  
  1196.  
  1197.  
  1198.  

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