Télécharger la plaquette Cast3M


fr en

Télécharger j3sure.eso

Retour à la liste

Numérotation des lignes : 

j3sure

  1. C J3SURE    SOURCE    CHAT      05/01/13    00:47:25     5004
  2.       SUBROUTINE J3SURE(VWORK1,IRET,TOL)
  3. C----------------------------------------------------
  4. C     ELIMINATION DES CAS TORDUS POUR SURF
  5. C     QUI CREE DE NOUVELLE FACES:
  6. C
  7. C   - CYCLE INTERIEUR DE TROU
  8. C   - CYCLE DE TROU AVEC LE CONTOUR PRINCIPAL
  9. C
  10. C     PP 12/98
  11. C     Pierre Pegon/JRC Ispra
  12. C----------------------------------------------------
  13.       IMPLICIT INTEGER(I-N)
  14.       IMPLICIT REAL*8(A-H,O-Z)
  15.       DIMENSION XY(2)
  16. C
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. C
  20.       SEGMENT VWORK
  21.         INTEGER FWWORK(NFACE)
  22.       ENDSEGMENT
  23.       POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK
  24. C
  25.       SEGMENT WWORK
  26.         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  27.         INTEGER FWORK
  28.         INTEGER TWORK(NTROU)
  29.       ENDSEGMENT
  30.       POINTEUR WWORK1.WWORK
  31. C
  32.       SEGMENT WORK
  33.         REAL*8 XYC(2,NPTO)
  34.         INTEGER IST(3,NPTO)
  35.         REAL*8 DENS(NPTO)
  36.         INTEGER JUN
  37.       ENDSEGMENT
  38.       POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK
  39. C
  40.       SEGMENT JUNC
  41.         INTEGER CRO(2,NPTO)
  42.       ENDSEGMENT
  43. C
  44.       SEGMENT WCYCL
  45. C       CONNEC(.,.,J)=NO DU CONTOUR CONCERNE
  46. C       CONNEC(.,I,J)=IEME VOISIN DU TROU J
  47. C       CONNEC(1,.,.)=NO DU POINT
  48. C       CONNEC(2,.,.)=NO DU CONTOUR EN CONTACT
  49. C       CONNEC(1,.,.)=NO DU POINT
  50.         INTEGER CONNEC(3,NTROV,NTROV)
  51. C       NCONNE(J)=NB DE VOISIN DU TROU J
  52.         INTEGER NCONNE(NTROV)
  53. C       NCYCLE(.,I)=NIVEAU DANS LE CYCLE DE TROU
  54. C       NCYCLE(1,,)=TROU AMONT
  55. C       NCYCLE(2,,)=TROU COURANT
  56. C       NCYCLE(3,,)=RANG DU VOISIN COURANT
  57.         INTEGER NCYCLE(3,NTROV)
  58.         INTEGER NINDEX(NTROV)
  59.       ENDSEGMENT
  60. C
  61. C     ON RENTRE AVEC DES ENSEMBLE DE VWORK REPRESENTANT CHACUN
  62. C     UN BLOCK COMPOSE DE FACE
  63. C
  64.       NBLOCK=VWORK1.FWWORK(/1)
  65. C
  66. C     ON BOUCLE SUR CHAQUE BLOCK
  67. C
  68.       DO IE1=1,NBLOCK
  69.         VWORK=VWORK1.FWWORK(IE1)
  70.         NFACF=FWWORK(/1)
  71. C
  72. C     ON BOUCLE SUR CHAQUE FACE (ON SIMULE DO 1000 IE2=1,NFACE
  73. C
  74. C       DO 1000 IE2=1,NFACE
  75. C
  76.         IE2=0
  77.  1000   IE2=IE2+1
  78.         IF (IE2.GT.NFACF)GOTO 1001
  79. C
  80.           WWORK=FWWORK(IE2)
  81.           NTROU=TWORK(/1)
  82. C
  83. C     S'IL Y A MOINS DE 2 TROUS, IL N'Y A PAS POSSIBILITE DE CYCLE INTE
  84. C     OU EXTE ET ALORS ON NE FAIT RIEN
  85. C     EN FAIT J3SURE LUI MEME PEUT CREER DES FACES AVEC UN TROU... QUI
  86. C     SONT CANDIDAT A LA COUPE...
  87. C
  88. C        IF(NTROU.LT.2)GOTO 1000
  89.          IF(NTROU.EQ.0)GOTO 1000
  90. C
  91. C     ON CHERCHE QUI EST EN CONTACT (PONCTUEL) AVEC QUOI
  92. C     ON CHERCHE MEME AU DELA DE 1 PT [CAR LA COALESCENCE DE TROUS EN
  93. C     CONTACT AVEC UN SEUL POINT PEUT CREER DU CONTACT MULTI POINT!)
  94. C
  95.           NTROV=NTROU+1
  96.           SEGINI,WCYCL
  97.           DO JE1=1,NTROU
  98.             NCONNE(JE1)=0
  99.           ENDDO
  100. C
  101. C WARNING: S'IL N'Y A QU'UN SEUL TROU... ON REGARDE DIRECTEMENT
  102. C          LES POSSIBILITES DE COUPE
  103. C
  104.           IF(NTROU.EQ.1)GOTO 100
  105. C
  106.           DO JE1=1,NTROU-1
  107.             WORK1=TWORK(JE1)
  108.             NPTO1=WORK1.XYC(/2)
  109.             DO JE2=JE1+1,NTROU
  110.               WORK2=TWORK(JE2)
  111.               NPTO2=WORK2.XYC(/2)
  112.               DO JE3=1,NPTO1
  113.                 XX=WORK1.XYC(1,JE3)
  114.                 YY=WORK1.XYC(2,JE3)
  115.                 DO JE4=1,NPTO2
  116.                   DO JE5=1,2
  117.                     XY(JE5)=WORK2.XYC(JE5,JE4)
  118.                   ENDDO
  119.                   DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  120.                   IF(DIS.LT.TOL)THEN
  121. C
  122. C WARNING ON TESTE ICI LA POSSIBILITE DE CONTACT MULTI PONCTUEL QUE L'ON
  123. C TRAITERA PAR COHALESCENCE
  124. C
  125.                     IF(NCONNE(JE1).GT.0)THEN
  126.                       DO JE6=1,NCONNE(JE1)
  127.                         IF(CONNEC(2,JE6,JE1).EQ.JE2)GOTO 300
  128.                       ENDDO
  129.                     ENDIF
  130. C
  131.                     NCONNE(JE1)=NCONNE(JE1)+1
  132.                     CONNEC(1,NCONNE(JE1),JE1)=JE3
  133.                     CONNEC(2,NCONNE(JE1),JE1)=JE2
  134.                     CONNEC(3,NCONNE(JE1),JE1)=JE4
  135.                     NCONNE(JE2)=NCONNE(JE2)+1
  136.                     CONNEC(1,NCONNE(JE2),JE2)=JE4
  137.                     CONNEC(2,NCONNE(JE2),JE2)=JE1
  138.                     CONNEC(3,NCONNE(JE2),JE2)=JE3
  139.                   ENDIF
  140.                 ENDDO
  141.               ENDDO
  142.             ENDDO
  143.           ENDDO
  144. C
  145. C     SI IL N'Y A QUE 2 TROUS, ON SAUTE DIRECTEMENT AUX CYCLES EXTERNES
  146. C
  147.           IF(NTROU.EQ.2)GOTO 100
  148. C
  149. C     ON REGARDE LE NB DE TROU EN CONTACT AVEC AU MOINS 2 AUTRES
  150. C
  151.           ICONT2=0
  152.           DO JE1=1,NTROU
  153.             IF(NCONNE(JE1).GE.2)THEN
  154.               ICONT2=ICONT2+1
  155.               NINDEX(ICONT2)=JE1
  156.             ENDIF
  157.           ENDDO
  158. C
  159. C     SI CE NB EST PLUS PETIT QUE 3, ALORS ON PASSE AUX CYCLES EXTERNES
  160. C
  161.           IF(ICONT2.LT.3)GOTO 100
  162. C
  163. C     SINON ON FORME LES CYCLES EN DONNANT COMME RACINE, SUCCESSIVEMENT,
  164. C     LES ICONT2-2 PREMIERS TROUS AYANT 2 VOISINS
  165. C
  166.           DO 3 IE3=1,ICONT2-2
  167. C
  168. C     ON CHERCHE A FORMER LES CYCLES A PARTIR DES VOISINS DU PREMIER
  169. C     TROU
  170. C
  171.             ITROU=1
  172.             NCYCLE(1,ITROU)=0
  173.             NCYCLE(2,ITROU)=NINDEX(IE3)
  174.             NCYCLE(3,ITROU)=0
  175.  2          CONTINUE
  176. C
  177. C  1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0)
  178. C     ---> ON PASSE A LA RACINE SUIVANTE
  179. C
  180.             IF(ITROU.EQ.0)THEN
  181.               GOTO 3
  182.             ENDIF
  183. C
  184. C  2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT
  185. C     SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT
  186. C
  187.             NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1
  188.             IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN
  189.               ITROU=ITROU-1
  190.               GOTO 2
  191.             ENDIF
  192. C
  193. C  3) ON RECUPERE LE NUMERO DU VOISIN
  194. C       SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE
  195. C       SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE
  196. C       SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE
  197. C       SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE
  198. C
  199.             IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU))
  200.             IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 2
  201.             IF(NCONNE(IVOIS).LT.2)GOTO 2
  202. C
  203. C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT
  204. C          QU'IL Y EST AU MOINS 3 TROUS NON PARASITES...
  205. C
  206. C           IF(IVOIS.EQ.NINDEX(IE3))GOTO 31
  207.             IF(IVOIS.EQ.NINDEX(IE3))THEN
  208.               NCYCLE(1,1)=NCYCLE(2,ITROU)
  209.               IITROU=0
  210.               DO JE1=1,ITROU
  211.                 IPAREN=NCYCLE(1,JE1)
  212.                 ICOURA=NCYCLE(2,JE1)
  213.                 IF(JE1.EQ.ITROU)THEN
  214.                   IENFAN=NINDEX(IE3)
  215.                 ELSE
  216.                   IENFAN=NCYCLE(2,JE1+1)
  217.                 ENDIF
  218.                 IPSTAR=0
  219.                 IPFIN=0
  220.                 DO JE2=1,NCONNE(ICOURA)
  221.                   IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  222.      1              IPSTAR=CONNEC(1,JE2,ICOURA)
  223.                   IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  224.      1              IPFIN=CONNEC(1,JE2,ICOURA)
  225.                 ENDDO
  226.                 IF(IPSTAR.EQ.IPFIN)THEN
  227.                   NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  228.                 ELSE
  229.                   IITROU=IITROU+1
  230.                 ENDIF
  231.               ENDDO
  232.               IF(IITROU.GE.3)THEN
  233.                 GOTO 31
  234.               ELSE
  235.                 DO JE1=1,ITROU
  236.                   NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1))
  237.                 ENDDO
  238.                 GOTO 2
  239.               ENDIF
  240.             ENDIF
  241. C
  242. C FIN VALIDATION
  243. C
  244.             ITROU=ITROU+1
  245.             NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1)
  246.             NCYCLE(2,ITROU)=IVOIS
  247.             NCYCLE(3,ITROU)=0
  248.             GOTO 2
  249. C
  250.  3        CONTINUE
  251. C
  252. C     SI ON EST LA, C'EST QU'IL N'Y A PAS DE CYCLE INTERNE ET ON PASSE
  253. C     AUX CYCLES EXTERNES
  254. C
  255.           GOTO 100
  256. C
  257. C     C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)...
  258. C
  259. C31       NCYCLE(1,1)=NCYCLE(2,ITROU)
  260.  31       CONTINUE
  261. C
  262. C     CREATION DU NOUVEAU TROU ET DE LA NOUVELLE FACE
  263. C
  264. C  1) CREATION DU COUNTOUR
  265. C
  266.           NPTO=0
  267.           SEGINI,WORK
  268. C
  269. C  2) BOUCLE SUR LES TROU DANS UN SENS
  270. C
  271.           DO 4 JE1=1,ITROU
  272. C
  273. C  3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  274. C
  275.             IPAREN=NCYCLE(1,JE1)
  276.             ICOURA=NCYCLE(2,JE1)
  277.             IF(ICOURA.LT.0)GOTO 4
  278.             IF(JE1.EQ.ITROU)THEN
  279.               IENFAN=NINDEX(IE3)
  280.             ELSE
  281.               IENFAN=ABS(NCYCLE(2,JE1+1))
  282.             ENDIF
  283.             IPSTAR=0
  284.             IPFIN=0
  285.             DO JE2=1,NCONNE(ICOURA)
  286.               IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  287.      1           IPSTAR=CONNEC(1,JE2,ICOURA)
  288.               IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  289.      1           IPFIN =CONNEC(1,JE2,ICOURA)
  290.             ENDDO
  291.             IF(IPSTAR*IPFIN.EQ.0)THEN
  292.               IRAISO=1
  293.               SEGSUP,WORK
  294.               GOTO 9999
  295.             ENDIF
  296. C
  297. C  4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE
  298. C     CONTACT ENTRE 2 "VRAIS" VOISINS
  299. C
  300. C           IF(IPSTAR.EQ.IPFIN)THEN
  301. C             NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  302. C             GOTO 4
  303. C           ENDIF
  304. C
  305. C  5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  306. C
  307.             WORK1=TWORK(ICOURA)
  308.             NPTO1=WORK1.XYC(/2)
  309.             NPTO2=IPFIN-IPSTAR
  310.             IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  311.             NPTO=NPTO+NPTO2
  312.             SEGADJ,WORK
  313.             IPCOUR=IPFIN
  314.             DO JE2=1,NPTO2
  315.               IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  316.               XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  317.               XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  318.               DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  319.             ENDDO
  320.  4        CONTINUE
  321. C
  322. C  6) NOUVEAU CONTOUR DANS WORK3
  323. C
  324.           WORK3=WORK
  325. C
  326. C  7) CREATION DU CONTOUR
  327. C
  328.           NPTO=0
  329.           SEGINI,WORK
  330. C
  331. C  8) BOUCLE SUR LES TROU DANS L'AUTRE SENS
  332. C
  333.           DO 5 JE1=ITROU,1,-1
  334. C
  335. C  9) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  336. C     (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR)
  337. C
  338.             IPAREN=NCYCLE(1,JE1)
  339.             ICOURA=NCYCLE(2,JE1)
  340.             IF(ICOURA.LT.0)GOTO 5
  341.             IF(JE1.EQ.ITROU)THEN
  342.               IENFAN=NINDEX(IE3)
  343.             ELSE
  344.               IENFAN=ABS(NCYCLE(2,JE1+1))
  345.             ENDIF
  346.             IPSTAR=0
  347.             IPFIN=0
  348.             DO JE2=1,NCONNE(ICOURA)
  349.               IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  350.      1           IPFIN=CONNEC(1,JE2,ICOURA)
  351.               IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  352.      1           IPSTAR=CONNEC(1,JE2,ICOURA)
  353.             ENDDO
  354.             IF(IPSTAR*IPFIN.EQ.0)THEN
  355.               IRAISO=2
  356.               SEGSUP,WORK,WORK3
  357.               GOTO 9999
  358.             ENDIF
  359. C
  360. C 10) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  361. C
  362.             WORK1=TWORK(ICOURA)
  363.             NPTO1=WORK1.XYC(/2)
  364.             NPTO2=IPFIN-IPSTAR
  365.             IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  366.             NPTO=NPTO+NPTO2
  367.             SEGADJ,WORK
  368.             IPCOUR=IPFIN
  369.             DO JE2=1,NPTO2
  370.               IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  371.               XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  372.               XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  373.               DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  374.             ENDDO
  375.  5        CONTINUE
  376. C
  377. C 11) NOUVEAU CONTOUR DANS WORK2
  378. C
  379.           WORK2=WORK
  380. C
  381. C 12) ON REGARDE L'ORIENTATION DE WORK2 ET WORK3
  382. C     WORK2 SERA LE TROU ET WORK3 LA NOUVELLE FACE
  383. C
  384.           NPTO2=WORK2.XYC(/2)
  385.           CALL J3ORIE(0,WORK2.XYC,WORK2.DENS,NPTO2,IORI2,TOL,IRET)
  386.           IF(IRET.NE.0)THEN
  387.             IRAISO=3
  388.             SEGSUP,WORK2,WORK3
  389.             GOTO 9999
  390.           ENDIF
  391.           NPTO3=WORK3.XYC(/2)
  392.           CALL J3ORIE(0,WORK3.XYC,WORK3.DENS,NPTO3,IORI3,TOL,IRET)
  393.           IF(IRET.NE.0)THEN
  394.             IRAISO=4
  395.             SEGSUP,WORK2,WORK3
  396.             GOTO 9999
  397.           ENDIF
  398.           IF(IORI2*IORI3.EQ.1)THEN
  399.             IRAISO=5
  400.             SEGSUP,WORK2,WORK3
  401.             GOTO 9999
  402.           ENDIF
  403.           IF(IORI2.EQ.1)THEN
  404.             WORK=WORK3
  405.             WORK3=WORK2
  406.             WORK2=WORK
  407.           ENDIF
  408. C
  409. C 13) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT
  410. C     COALESCE
  411. C
  412.           WORK=TWORK(NINDEX(IE3))
  413.           SEGSUP,WORK
  414.           TWORK(NINDEX(IE3))=WORK2
  415.           DO JE1=2,ITROU
  416.             ICOURA=NCYCLE(2,JE1)
  417.             IF(ICOURA.GT.0)THEN
  418.               WORK=TWORK(ICOURA)
  419.               IF(WORK.NE.0)THEN
  420.                 SEGSUP,WORK
  421.                 TWORK(ICOURA)=0
  422.               ENDIF
  423.             ENDIF
  424.           ENDDO
  425. C
  426. C 14) ET LA NOUVELLE FACE (A VOIR LE FORMAT)
  427. C
  428.           NFACE=1
  429.           SEGINI,VWORK2
  430.           NTROU=0
  431.           SEGINI,WWORK1
  432.           WWORK1.FWORK=WORK3
  433.           VWORK2.FWWORK(1)=WWORK1
  434. C          CALL J3MUFA(VWORK2,TOL,IRET)
  435. C
  436. C 15) TRANSFERT DES TROUS DE LA FACE COURANTE DANS LA NOUVELLE
  437. C     QUE L'ON AJOUTE AU BLOCK COURRANT
  438. C
  439.           CALL J3HEAD(WWORK,VWORK2)
  440.           CALL J3COAK(WWORK,VWORK2,TOL,IRET)
  441.           IF(IRET.NE.0)THEN
  442.             IRAISO=4
  443.             SEGSUP,WORK2,WORK3,VWORK2,WWORK1
  444.             GOTO 9999
  445.           ENDIF
  446.           NFACE=NFACF+1
  447.           SEGADJ,VWORK
  448.           FWWORK(NFACE)=VWORK2.FWWORK(1)
  449. C
  450. C 16) ON AJUSTE LA FACE COURRANTE
  451. C
  452.           CALL J3REDU(WWORK)
  453. C
  454. C      ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2
  455. C
  456.           SEGSUP,WCYCL,VWORK2
  457.           IE2=IE2-1
  458.           NFACF=NFACE
  459.           GOTO 1000
  460. C
  461. C     DEBUT DE CYCLE EXTERNE
  462. C
  463.  100      CONTINUE
  464. C
  465. C     ON COMPLETE QUI TOUCHE QUOI AVEC LA DERNIERE FACE: LE CONTOUR EXTE
  466. C     ICI, ON CHERCHE AU DELA DE 1 PT CAR UN TROU FORME PAR COHALESCENCE
  467. C     CYCLIQUE PEUT PRESENTE CETTE PATHOLOGIE
  468. C
  469.           NCONNE(NTROV)=0
  470.           WORK1=FWORK
  471.           NPTO1=WORK1.XYC(/2)
  472.           DO JE2=1,NTROU
  473.             WORK2=TWORK(JE2)
  474.             NPTO2=WORK2.XYC(/2)
  475.             DO JE3=1,NPTO1
  476.               XX=WORK1.XYC(1,JE3)
  477.               YY=WORK1.XYC(2,JE3)
  478.               DO JE4=1,NPTO2
  479.                 DO JE5=1,2
  480.                   XY(JE5)=WORK2.XYC(JE5,JE4)
  481.                 ENDDO
  482.                 DIS=SQRT((XX-XY(1))**2+(YY-XY(2))**2)
  483.                 IF(DIS.LT.TOL)THEN
  484.                   NCONNE(NTROV)=NCONNE(NTROV)+1
  485.                   CONNEC(1,NCONNE(NTROV),NTROV)=JE3
  486.                   CONNEC(2,NCONNE(NTROV),NTROV)=JE2
  487.                   CONNEC(3,NCONNE(NTROV),NTROV)=JE4
  488.                   NCONNE(JE2)=NCONNE(JE2)+1
  489.                   CONNEC(1,NCONNE(JE2),JE2)=JE4
  490.                   CONNEC(2,NCONNE(JE2),JE2)=NTROV
  491.                   CONNEC(3,NCONNE(JE2),JE2)=JE3
  492.                 ENDIF
  493.               ENDDO
  494.             ENDDO
  495.           ENDDO
  496. C
  497. C     SI LE CONTOUR EXTE N'EST PAS EN CONTACT AVEC AU MOINS 2 TROUS ALORS ON PASSE
  498. C
  499.           IF(NCONNE(NTROV).LT.2)THEN
  500.             SEGSUP,WCYCL
  501.             GOTO 1000
  502.           ENDIF
  503. C
  504. C     SI L'UN DES TROUS EST EN BI-CONTACT AVEC LE CONTOUR EXTE, ON SAUTE
  505. C     DIRECTEMENT A LA COUPE SANS FORMER D'ARBRE
  506. C
  507.           DO JE1=1,NTROU
  508.             NVOIS1=0
  509.             IF(NCONNE(JE1).GT.0)THEN
  510.               DO JE2=1,NCONNE(JE1)
  511.                 IF(CONNEC(2,JE2,JE1).EQ.NTROV)NVOIS1=NVOIS1+1
  512.               ENDDO
  513.             ENDIF
  514.             IF(NVOIS1.GE.2)THEN
  515.               WORK2=TWORK(JE1)
  516.               TWORK(JE1)=0
  517.               GOTO 200
  518.             ENDIF
  519.           ENDDO
  520. C
  521. C     RECHERCHE DE CYCLE AVEC LE CONTOUR EXTERIEUR COMME RACINE
  522. C
  523.           ITROU=1
  524.           NCYCLE(1,ITROU)=0
  525.           NCYCLE(2,ITROU)=NTROV
  526.           NCYCLE(3,ITROU)=0
  527.  102      CONTINUE
  528. C
  529. C  1) ON A TOUT INSPECTE SANS RIEN TROUVE (RETOUR AU NIVEAU 0)
  530. C     ---> ON PASSE A LA FACE SUIVANTE
  531. C
  532.           IF(ITROU.EQ.0)THEN
  533.             SEGSUP,WCYCL
  534.             GOTO 1000
  535.           ENDIF
  536. C
  537. C  2) ON PASSE AU VOISIN SUIVANT DU TROU DU NIVEAU COURANT
  538. C     SI IL N'Y EN A PAS ON RETOURNE AU NIVEAU PRECEDENT
  539. C
  540.           NCYCLE(3,ITROU)=NCYCLE(3,ITROU)+1
  541.           IF(NCYCLE(3,ITROU).GT.NCONNE(NCYCLE(2,ITROU)))THEN
  542.             ITROU=ITROU-1
  543.             GOTO 102
  544.           ENDIF
  545. C
  546. C  3) ON RECUPERE LE NUMERO DU VOISIN
  547. C       SI LE VOISIN EST EGAL AU TROU PARENT ON PASSE
  548. C       SI LE VOISIN A MOINS DE 2 VOISINS ON PASSE
  549. C       SI LE VOISIN EST LE TROU NO.1 ON A IDENTIFIE LE CYCLE
  550. C       SINON, LE VOISIN DEVIENT LE TROU DE NIVEAU SUIVANT ET ON CONTINUE
  551. C
  552.           IVOIS=CONNEC(2,NCYCLE(3,ITROU),NCYCLE(2,ITROU))
  553.           IF(IVOIS.EQ.NCYCLE(1,ITROU))GOTO 102
  554.           IF(NCONNE(IVOIS).LT.2)GOTO 102
  555.  
  556. C
  557. C WARNING: SI ON A FINI LA BOUCLE, IL FAUT LA VALIDER... C.A.D. QU'IL FAUT
  558. C          QU'IL Y EST AU MOINS 3 TROUS NON PARASITES...
  559. C
  560. C         IF(IVOIS.EQ.NTROV)GOTO 104
  561.           IF(IVOIS.EQ.NTROV)THEN
  562.             NCYCLE(1,1)=NCYCLE(2,ITROU)
  563.             IITROU=0
  564.             DO JE1=1,ITROU
  565.               IPAREN=NCYCLE(1,JE1)
  566.               ICOURA=NCYCLE(2,JE1)
  567.               IF(JE1.EQ.ITROU)THEN
  568.                 IENFAN=NINDEX(IE3)
  569.               ELSE
  570.                 IENFAN=NCYCLE(2,JE1+1)
  571.               ENDIF
  572.               IPSTAR=0
  573.               IPFIN=0
  574.               DO JE2=1,NCONNE(ICOURA)
  575.                 IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  576.      1            IPSTAR=CONNEC(1,JE2,ICOURA)
  577.                 IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  578.      1            IPFIN=CONNEC(1,JE2,ICOURA)
  579.               ENDDO
  580.               IF(IPSTAR.EQ.IPFIN)THEN
  581.                 NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  582.               ELSE
  583.                 IITROU=IITROU+1
  584.               ENDIF
  585.             ENDDO
  586.             IF(IITROU.GE.3)THEN
  587.               GOTO 104
  588.             ELSE
  589.               DO JE1=1,ITROU
  590.                 NCYCLE(2,JE1)=ABS(NCYCLE(2,JE1))
  591.               ENDDO
  592.               GOTO 102
  593.             ENDIF
  594.           ENDIF
  595. C
  596. C FIN VALIDATION
  597. C
  598.           ITROU=ITROU+1
  599.           NCYCLE(1,ITROU)=NCYCLE(2,ITROU-1)
  600.           NCYCLE(2,ITROU)=IVOIS
  601.           NCYCLE(3,ITROU)=0
  602.           GOTO 102
  603. C
  604. C     C'EST LA QUE L'ON SORT EN CAS DE CYCLE EN COMPLETANT NCYCLE(1,1)...
  605. C
  606. C104      NCYCLE(1,1)=NCYCLE(2,ITROU)
  607.  104      CONTINUE
  608. C
  609. C     COHALESCENCE PAR LA POINTE DES TROUS QUI FORMENT LE CYCLE
  610. C
  611. C
  612. C  1) CREATION DU CONTOUR
  613. C
  614.           NPTO=0
  615.           SEGINI,WORK
  616. C
  617. C  2) BOUCLE SUR LES TROU DANS UN SENS
  618. C
  619.           DO 105 JE1=2,ITROU
  620. C
  621. C  3) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  622. C
  623.             IPAREN=NCYCLE(1,JE1)
  624.             ICOURA=NCYCLE(2,JE1)
  625.             IF(ICOURA.LT.0)GOTO 105
  626.             IF(JE1.EQ.ITROU)THEN
  627.               IENFAN=NTROV
  628.             ELSE
  629.               IENFAN=ABS(NCYCLE(2,JE1+1))
  630.             ENDIF
  631.             IPSTAR=0
  632.             IPFIN=0
  633.             DO JE2=1,NCONNE(ICOURA)
  634.               IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  635.      1          IPSTAR=CONNEC(1,JE2,ICOURA)
  636.               IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  637.      1          IPFIN=CONNEC(1,JE2,ICOURA)
  638.             ENDDO
  639.             IF(IPSTAR*IPFIN.EQ.0)THEN
  640.               IRAISO=10
  641.               SEGSUP,WORK
  642.               GOTO 9999
  643.             ENDIF
  644. C
  645. C  4) ON ELIMINE LE CAS D'UN TROU PARASITE EN CONTACT PONCTUEL AU PT DE
  646. C     CONTACT ENTRE 2 "VRAIS" VOISINS
  647. C
  648. C           IF(IPSTAR.EQ.IPFIN)THEN
  649. C             NCYCLE(2,JE1)=-NCYCLE(2,JE1)
  650. C             GOTO 105
  651. C           ENDIF
  652. C
  653. C  5) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  654. C
  655.             WORK1=TWORK(ICOURA)
  656.             NPTO1=WORK1.XYC(/2)
  657.             NPTO2=IPFIN-IPSTAR
  658.             IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  659.             NPTO=NPTO+NPTO2
  660.             SEGADJ,WORK
  661.             IPCOUR=IPFIN
  662.             DO JE2=1,NPTO2
  663.               IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  664.               XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  665.               XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  666.               DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  667.             ENDDO
  668.  105      CONTINUE
  669.  
  670. C
  671. C  6) BOUCLE SUR LES TROU DANS L'AUTRE SENS
  672. C
  673.           DO 106 JE1=ITROU,2,-1
  674. C
  675. C  7) LOCALISATION DES TROUS VOISINS ET DES PT DE CONTACTS
  676. C     (ON ECHANGE LE ROLE DE IPFIN ET IPSTAR)
  677. C
  678.             IPAREN=NCYCLE(1,JE1)
  679.             ICOURA=NCYCLE(2,JE1)
  680.             IF(ICOURA.LT.0)GOTO 106
  681.             IF(JE1.EQ.ITROU)THEN
  682.               IENFAN=NTROV
  683.             ELSE
  684.               IENFAN=ABS(NCYCLE(2,JE1+1))
  685.             ENDIF
  686.             IPSTAR=0
  687.             IPFIN=0
  688.             DO JE2=1,NCONNE(ICOURA)
  689.               IF(CONNEC(2,JE2,ICOURA).EQ.IPAREN)
  690.      1           IPFIN=CONNEC(1,JE2,ICOURA)
  691.               IF(CONNEC(2,JE2,ICOURA).EQ.IENFAN)
  692.      1           IPSTAR=CONNEC(1,JE2,ICOURA)
  693.             ENDDO
  694.             IF(IPSTAR*IPFIN.EQ.0)THEN
  695.               IRAISO=11
  696.               SEGSUP,WORK
  697.               GOTO 9999
  698.             ENDIF
  699. C
  700. C  8) ON AJOUTE LES POINTS (EN PARTANT DE LA FIN)
  701. C
  702.             WORK1=TWORK(ICOURA)
  703.             NPTO1=WORK1.XYC(/2)
  704.             NPTO2=IPFIN-IPSTAR
  705.             IF(NPTO2.LT.0)NPTO2=NPTO2+NPTO1
  706.             NPTO=NPTO+NPTO2
  707.             SEGADJ,WORK
  708.             IPCOUR=IPFIN
  709.             DO JE2=1,NPTO2
  710.               IPCOUR=IPCOUR-1+(1/IPCOUR)*NPTO1
  711.               XYC(1,NPTO-JE2+1)=WORK1.XYC(1,IPCOUR)
  712.               XYC(2,NPTO-JE2+1)=WORK1.XYC(2,IPCOUR)
  713.               DENS(NPTO-JE2+1)=WORK1.DENS(IPCOUR)
  714.             ENDDO
  715.  106      CONTINUE
  716. C
  717. C  9) NOUVEAU CONTOUR DANS WORK2
  718. C
  719.           WORK2=WORK
  720. C
  721. C 10) ON AJUSTE LES TROUS (ON SUPRIME CEUX QUI ONT EFFECTIVEMENT
  722. C     COALESCE
  723. C
  724.           DO JE1=1,ITROU
  725.             ICOURA=NCYCLE(2,JE1)
  726.             IF(ICOURA.GT.0)THEN
  727.               WORK=TWORK(ICOURA)
  728.               IF(WORK.NE.0)THEN
  729.                 SEGSUP,WORK
  730.                 TWORK(ICOURA)=0
  731.               ENDIF
  732.             ENDIF
  733.           ENDDO
  734. C
  735. C     COUPE: LA FACE "B" EST DANS WORK2 ET "A" DANS WWORK
  736. C
  737. C         ON ORIENTE CORRECTEMENT B
  738. C         ON CHERCHE LES CONNEXIONS
  739. C         ON COUPE
  740. C         ON NE S'OCCUPE QUE DE LA PARTIE EXTERIEURE A LA COUPE
  741. C
  742.  200      CONTINUE
  743.           CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,WORK2.XYC(/2),1,TOL,IRET)
  744.           IF(IRET.NE.0)THEN
  745.             IRAISO=20
  746.             GOTO 9999
  747.           ENDIF
  748.           WORK1=FWORK
  749.           CALL J3COTO(WORK2,WORK1,TOL,IRET)
  750.           IF(IRET.NE.0)THEN
  751.             IRAISO=21
  752.             GOTO 9999
  753.           ENDIF
  754.           CALL J3COTO(WORK1,WORK2,TOL,IRET)
  755.           IF(IRET.NE.0)THEN
  756.             IRAISO=22
  757.             GOTO 9999
  758.           ENDIF
  759.           CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  760.           IF(IRET.NE.0)THEN
  761.             IRAISO=23
  762.             GOTO 9999
  763.            ENDIF
  764.           CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  765.           IF(IRET.NE.0)THEN
  766.             IRAISO=24
  767.             GOTO 9999
  768.           ENDIF
  769.           FWORK=WORK1
  770.           CALL J3COUP(WWORK,WORK2,VWDUMM,VWORK2,1,TOL,IRET)
  771.           CALL J3DET1(VWDUMM)
  772.           CALL J3HEAD(WWORK,VWORK2)
  773. C
  774. C     ON AJOUTE LES NOUVELLES FACES ET ON FLINGUE l'ANCIENNE
  775. C
  776.           NFACN=VWORK2.FWWORK(/1)
  777.           IF(NFACN.EQ.0)THEN
  778.             IRET=IRET+1
  779.             IRAISO=25
  780.             GOTO 9999
  781.           ENDIF
  782.           WORK=FWORK
  783.           SEGSUP,WWORK,WORK
  784.           FWWORK(IE2)=VWORK2.FWWORK(NFACN)
  785.           NFACE=NFACF+NFACN-1
  786.           SEGADJ,VWORK
  787.           DO JE1=1,NFACN-1
  788.             FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1)
  789.           ENDDO
  790. C
  791. C     ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2
  792. C
  793.           SEGSUP,WCYCL,VWORK2
  794.           IE2=IE2-1
  795.           NFACF=NFACE
  796.           GOTO 1000
  797. C
  798. C     ON ENTRE DANS LE CAS DU CONTACT MULTI PONCTUEL ENTRE 2 TROUS JE1 ET JE2
  799. C
  800.  300      CONTINUE
  801.           WORK1=TWORK(JE1)
  802.           WORK2=TWORK(JE2)
  803. C
  804. C     ON VERIFIE...
  805. C
  806.           CALL J3COTO(WORK2,WORK1,TOL,IRET)
  807.           IF(IRET.NE.0)THEN
  808.             IRAISO=30
  809.             GOTO 9999
  810.           ENDIF
  811.           CALL J3COTO(WORK1,WORK2,TOL,IRET)
  812.           IF(IRET.NE.0)THEN
  813.             IRAISO=31
  814.             GOTO 9999
  815.           ENDIF
  816.           CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  817.           IF(IRET.NE.0)THEN
  818.             IRAISO=32
  819.             GOTO 9999
  820.            ENDIF
  821.           CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  822.           IF(IRET.NE.0)THEN
  823.             IRAISO=33
  824.             GOTO 9999
  825.           ENDIF
  826. C
  827. C     ON COHALESCE DANS VWORK2
  828. C
  829.           CALL J3COAL(WORK1,WORK2,.FALSE.,VWORK2,NFACEA,TOL,IRET)
  830.           IF(IRET.GT.0)THEN
  831.             IRAISO=34
  832.             GOTO 9999
  833.           ELSE
  834.             JUNC=WORK2.JUN
  835.             IF(JUNC.NE.0)SEGSUP,JUNC
  836.             SEGSUP,WORK2
  837.             TWORK(JE1)=WORK1
  838.             TWORK(JE2)=0
  839.           ENDIF
  840. C
  841. C     ON DISTRIBUE
  842. C
  843.           IF(NFACEA.GT.0)THEN
  844.             CALL J3HEAD(WWORK,VWORK2)
  845.             CALL J3COAK(WWORK,VWORK2,TOL,IRET)
  846.           ENDIF
  847. C
  848. C     ON AJUSTE
  849. C
  850.           CALL J3REDU(WWORK)
  851. C
  852. C     ON AJOUTE LES NOUVELLES FACES
  853. C
  854.           NFACN=VWORK2.FWWORK(/1)
  855.           IF(NFACN.EQ.0)THEN
  856.             IRET=IRET+1
  857.             IRAISO=35
  858.             GOTO 9999
  859.           ENDIF
  860.           NFACE=NFACF+NFACN
  861.           SEGADJ,VWORK
  862.           DO JE1=1,NFACN
  863.             FWWORK(NFACF+JE1)=VWORK2.FWWORK(JE1)
  864.           ENDDO
  865. C
  866. C     ON FAIT LE MENAGE ET ON RERENTRE DANS LA BOUCLE JE2
  867. C
  868.           SEGSUP,WCYCL,VWORK2
  869.           IE2=IE2-1
  870.           NFACF=NFACE
  871.           GOTO 1000
  872. C
  873. C
  874. C     FIN BOUCLE FACE
  875. C
  876.  1001   CONTINUE
  877. C
  878. C     FIN BOUCLE BLOCK
  879. C
  880.       ENDDO
  881. C
  882.       RETURN
  883. C
  884. C     CONFIGURATION IMPOSSIBLE
  885. C
  886.  9999 CONTINUE
  887.       IRET=IRET+1
  888.       SEGSUP,WCYCL
  889.       WRITE(IOIMP,*)' J3SURE: CONFIGURATION IMPOSSIBLE NO.',IRAISO
  890.       RETURN
  891. C
  892.       END
  893.  
  894.  
  895.  

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