Télécharger la plaquette Cast3M


fr en

Télécharger dicho3.eso

Retour à la liste

Numérotation des lignes : 

dicho3

  1. C DICHO3    SOURCE    PV        22/04/19    16:18:01     11344          
  2. C    NOUVELLE VERSION DE DICHO
  3. C     CE SOUS-PROGRAMME SERT A RESOUDRE LES SEGMENTS EN PARTIE CACHES
  4. C     ADAPTE A GIBI
  5. C  1995 TRAC option FACB et FASB P.PEGON JRC-ISPRA
  6. C
  7. C PP FACE avec trait blanc
  8.       SUBROUTINE DICHO3(XPROJ,MELEME,ICPR,XMIN,XMAX,YMIN,YMAX,IVU,NTSEG,
  9.      # NELEM,IICOL,IDEFCO,lblanc,LTSEG)
  10. C PP # NELEM,IICOL,IDEFCO)
  11. C
  12. C   TABLEAUX:   NTELCL  ELEMENTS CLASSES PAR ZONE
  13. C               NTSEG   SEGMENTS DOUTEUX
  14. C               NAUX    TABLEAU DE TRAVAIL
  15. C               KON     TABLEAU DES ELEMENTS TOUCHANT UN NOEUD
  16. C+PP trait blanc
  17.       IMPLICIT INTEGER(I-N)
  18.       logical lblanc
  19. C+PP
  20. *     SG 20160420 dans le coloriage des segments
  21. *     icoul : couleur courante (non definie = -3)
  22. *     kcoul : couleur voulue
  23. *     le but est de n'appeler chcoul que si qqch va etre trace
  24.       integer icoul,kcoul
  25.       DIMENSION XTR(2),YTR(2),ZTR(2)
  26.       REAL*8 A,B,C
  27.       REAL*8 XKK,XNN,XRAP,DNOM,DNUM,U,XPAR
  28.       REAL   XMIN,XMAX,YMIN,YMAX
  29.       SEGMENT NTSEG(0)
  30.       SEGMENT /XPROJ/(X(3,1))
  31.       SEGMENT IVU(NUMNP)
  32.       SEGMENT ICPR(0)
  33.       SEGMENT /TRAV1/(NTELEM(NELEM))
  34.       SEGMENT /TRAV2/(NTELCL(NREL),NAUX(NREL),IJK(4*NBZONE+2*NDEC+10))
  35.       SEGMENT /TRAV3/(IKON(IVU(/1)))
  36.       SEGMENT /TRAV4/(KON(ISUP,IVU(/1)))
  37.       SEGMENT /TRAV5/(DSTEL(NREL),NHZ(NELZON+2))
  38.  
  39. -INC PPARAM
  40. -INC CCOPTIO
  41. -INC CCGEOME
  42. -INC CCREEL
  43. -INC SMELEME
  44.       ZTR(1)=0
  45.       ZTR(2)=0
  46.       IF (NTSEG(/1).NE.0) GOTO 1
  47.       SEGSUP NTSEG
  48.       RETURN
  49. C   RIEN A FAIRE
  50.    1  A=30.
  51. *     CALL LIRREE(A,0,IRETOU)   GENANT EN FULLSCREEN
  52.       SEGACT ICPR
  53. C  ON REMPLIT NTELEM TABLEAU DE REGROUPEMENT DES ELEMENTS
  54.       SEGINI TRAV1
  55.       NREL=0
  56.       IPT1=MELEME
  57.       SEGACT MELEME
  58.       DO 3001 IOB=1,MAX(1,LISOUS(/1))
  59.       IF (LISOUS(/1).NE.0) THEN
  60.        IPT1=LISOUS(IOB)
  61.        SEGACT IPT1
  62.       ENDIF
  63.       IF (LTEL(1,IPT1.ITYPEL).EQ.0) GOTO 3003
  64.       IPB=IOB*NELEM
  65.       DO 3002 I=1,IPT1.NUM(/2)
  66.       DO 3005 J=1,IPT1.NUM(/1)
  67.       IF (IVU(ICPR(IPT1.NUM(J,I))).GT.0) GOTO 3006
  68.  3005 CONTINUE
  69.       GOTO 3002
  70.  3006 CONTINUE
  71.       NREL=NREL+1
  72.       NTELEM(NREL)=IPB+I
  73.  3002 CONTINUE
  74.  3003 CONTINUE
  75.  3001 CONTINUE
  76. *     write(6,*) ' nrel ',nrel
  77. C   NB MOYEN DE PTS PAR ZONE
  78.       RAP=(YMAX-YMIN)/(XMAX-XMIN)
  79.       NBZONE=REAL(NREL)/A+1
  80.       NDEC=SQRT(REAL(NBZONE)/RAP)
  81. **    write(6,*) 'nrel a nbzone ndec,rap',nrel,a,nbzone,ndec,rap
  82.       IF (NDEC.EQ.0) NDEC=1
  83.       MDEC=NBZONE/NDEC
  84.       IF (MDEC.EQ.0) MDEC=1
  85.       NBZONE=NDEC*MDEC
  86.       IF (IIMPI.EQ.1) WRITE (IOIMP,9912)  NBZONE
  87.  9912 FORMAT (' NOMBRE DE ZONES ',I6)
  88.       XDIST=XMAX-XMIN
  89.       YDIST=YMAX-YMIN
  90.       XDEC=XDIST/NDEC*1.00001
  91.       YDEC=YDIST/MDEC*1.00001
  92.       NUMNP=IVU(/1)
  93.       SMO=1E-5*XDIST*YDIST/NUMNP
  94. C  REMPLISSAGE DE KON TABLEAU ELEM (DE NTELEM) TOUCHANT NOEUD
  95.       SEGINI TRAV3
  96.       DO 5011 I=1,NREL
  97.       IOB=(NTELEM(I)-1)/NELEM
  98.       IF (LISOUS(/1).NE.0) THEN
  99.        IPT1=LISOUS(IOB)
  100.       ELSE
  101.        IPT1=MELEME
  102.       ENDIF
  103.       IEL=NTELEM(I)-IOB*NELEM
  104.       DO 5012 J=1,IPT1.NUM(/1)
  105.       K=ICPR(IPT1.NUM(J,IEL))
  106.       IKON(K)=IKON(K)+1
  107.  5012 CONTINUE
  108.  5011 CONTINUE
  109.       ISUP=0
  110.       DO 5013 I=1,IKON(/1)
  111.       ISUP=MAX(ISUP,IKON(I))
  112.  5013 CONTINUE
  113.       SEGINI TRAV4
  114.       DO 5015 I=1,NREL
  115.       IOB=(NTELEM(I)-1)/NELEM
  116.       IF (LISOUS(/1).NE.0) THEN
  117.        IPT1=LISOUS(IOB)
  118.       ELSE
  119.        IPT1=MELEME
  120.       ENDIF
  121.       IEL=NTELEM(I)-IOB*NELEM
  122.       DO 5016 J=1,IPT1.NUM(/1)
  123.       K=ICPR(IPT1.NUM(J,IEL))
  124.       KON(IKON(K),K)=NTELEM(I)
  125.       IKON(K)=IKON(K)-1
  126.  5016 CONTINUE
  127.  5015 CONTINUE
  128.       SEGSUP TRAV3
  129. C  REMPLISSAGE DE NAUX(I)=ZONE DE L'ELEMENT NTELEM(I)
  130. *     write(6,*) 'nrel nbzone ndec',nrel,nbzone,ndec
  131.       SEGINI TRAV2
  132.       DO 10 I=1,IJK(/1)
  133.   10  IJK(I)=0
  134.       DO 26 I=1,NREL
  135.       IOB=(NTELEM(I)-1)/NELEM
  136.       IF (LISOUS(/1).NE.0) THEN
  137.        IPT1=LISOUS(IOB)
  138.       ELSE
  139.        IPT1=MELEME
  140.       ENDIF
  141.       IEL=NTELEM(I)-IOB*NELEM
  142.       IDEC=0
  143.       IDEC2=0
  144.       IDEC3=0
  145.       INOEUD=ICPR(IPT1.NUM(1,IEL))
  146.       NAUXI=INT(real((X(1,INOEUD)-XMIN)/XDEC))+1+INT(real((X(2,INOEUD)
  147.      # -YMIN)/YDEC))*NDEC
  148.       DO 21 J=2,IPT1.NUM(/1)
  149.       INOEUD=ICPR(IPT1.NUM(J,IEL))
  150.       IZONE=INT(real((X(1,INOEUD)-XMIN)/XDEC))+1+
  151.      # INT(real((X(2,INOEUD)-YMIN)/YDEC))*NDEC
  152.       IF (NAUXI.EQ.IZONE) GOTO 21
  153.       IF (IDEC.EQ.0) IDEC=IZONE
  154.       IF (IDEC.EQ.IZONE) GOTO 21
  155.       IF (IDEC2.EQ.0) IDEC2=IZONE
  156.       IF (IDEC2.EQ.IZONE) GOTO 21
  157.       IF (IDEC3.EQ.0) IDEC3=IZONE
  158.       IF (IDEC3.EQ.IZONE) GOTO 21
  159.       NAUXI=0
  160.       GOTO 20
  161.   21  CONTINUE
  162.       IF (IDEC.EQ.0) GOTO 20
  163.       IDECC=NAUXI
  164.       IF (IDEC2.NE.0) GOTO 30
  165.       IVALID=ABS(IDECC-IDEC)
  166.       IF (IVALID.NE.1) GOTO 22
  167.       NAUXI=MIN(IDECC,IDEC)+NBZONE+1
  168.       GOTO 20
  169.   22  IF (IVALID.NE.NDEC) GOTO 23
  170.       NAUXI=MIN(IDECC,IDEC)+NBZONE+1+NBZONE+NDEC
  171.       GOTO 20
  172.   23  IF (IVALID.NE.NDEC+1) GOTO 24
  173.       NAUXI=MIN(IDECC,IDEC)+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1
  174.       GOTO 20
  175.   24  IF (IVALID.NE.NDEC-1) GOTO 25
  176.       NAUXI=MIN(IDECC,IDEC)-1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1
  177.       GOTO 20
  178.   25  NAUXI=0
  179.       GOTO 20
  180.   30  IF (IDEC3.NE.0) GOTO 33
  181.       I1=MIN(IDECC,IDEC,IDEC2)
  182.       I3=MAX(IDECC,IDEC,IDEC2)
  183.       I2=IDECC+IDEC+IDEC2-I1-I3
  184.       IAUX=I2-I1
  185.       IF (IAUX.EQ.1) GOTO 31
  186.       IF (IAUX.NE.NDEC) GOTO 32
  187.       IF (I3-I2.NE.1) GOTO 25
  188.       NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1
  189.       GOTO 20
  190.   32  IF (IAUX.NE.NDEC-1) GOTO 25
  191.       IF (I3-I2.NE.1) GOTO 25
  192.       NAUXI=I1-1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1
  193.       GOTO 20
  194.   31  IF (I3-I2.NE.NDEC.AND.I3-I2.NE.NDEC-1) GOTO 25
  195.       NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1
  196.       GOTO 20
  197.   33  I1=MIN(IDECC,IDEC,IDEC2,IDEC3)
  198.       I4=MAX(IDECC,IDEC,IDEC2,IDEC3)
  199.       IF (I4-I1.NE.NDEC+1) GOTO 25
  200.       IF (IDECC+IDEC+IDEC2+IDEC3.NE.2*(I1+I4)) GOTO 25
  201.       IF (IDECC*IDEC*IDEC2*IDEC3.NE.I1*(I1+1)*(I4-1)*I4) GOTO 25
  202.       NAUXI=I1+NBZONE+1+NBZONE+NDEC+NBZONE+NDEC+1
  203.   20  CONTINUE
  204.       NAUX(I)=NAUXI
  205.   26  CONTINUE
  206. C   LE TABLEAU NAUX EST REMPLI
  207. C    ON REMPLIT LE TABLEAU DE POINTEUR IJK (+1)
  208.       DO 50 I=1,NREL
  209.       IJK(NAUX(I)+1)=IJK(NAUX(I)+1)+1
  210.   50  CONTINUE
  211.       NELZON=IJK(1)
  212.       DO 51 I=2,IJK(/1)
  213.       NELZON=MAX(NELZON,IJK(I))
  214.   51  IJK(I)=IJK(I)+IJK(I-1)
  215. C  CLASSEMENT DES ELEMENTS DANS NTELCL
  216.       DO 60 I=1,NREL
  217.       IAD=IJK(NAUX(I)+1)
  218.       NTELCL(IAD)=NTELEM(I)
  219.       IJK(NAUX(I)+1)=IAD-1
  220.   60  CONTINUE
  221. C   CLASSEMENT DES ELEMENTS DANS CHAQUE ZONE PAR LA DISTANCE
  222.       IF (IIMPI.NE.0) WRITE (IOIMP,9914) NELZON
  223.  9914 FORMAT(' NOMBRE MAX D''ELEMENT PAR ZONE ',I6)
  224.       SEGSUP TRAV1
  225.       SEGINI TRAV5
  226.       DO 71 IW=2,IJK(/1)
  227.       IDEB=IJK(IW-1)+1
  228.       IFIN=IJK(IW)
  229.       IF (IDEB.GT.IFIN) GOTO 71
  230.       IDIFF=IFIN-IDEB+1
  231. *     write(6,*) ' dicho3 ideb ifin ',ideb,ifin
  232.       DO 72 I=IDEB,IFIN
  233.       IREL=NTELCL(I)
  234.       IOB=(IREL-1)/NELEM
  235.       IF (LISOUS(/1).NE.0) THEN
  236.        IPT1=LISOUS(IOB)
  237.       ELSE
  238.        IPT1=MELEME
  239.       ENDIF
  240.       IEL=IREL-IOB*NELEM
  241. C#      DSTEL(I)=XGRAND
  242.       DSTEL(I)=XSGRAN
  243. C ON CONSIDERE SEULEMENT LES SEGMENTS DONT AU MOINS UN POINT EST VU
  244.       IDEP=LPT(IPT1.ITYPEL)
  245.       IFIN1=LPT(IPT1.ITYPEL)+(LPL(IPT1.ITYPEL)-1)*2
  246.       IFIN2=IFIN1
  247.       IF (LPL(IPT1.ITYPEL).EQ.0.AND.LPT(IPT1.ITYPEL).NE.0)THEN
  248. C       Polygone
  249.         IFIN1=IDEP+2*IPT1.NUM(/1)-2
  250.         IFIN2=IFIN1 -2
  251.       ENDIF
  252.       DO 73 ISEG=IDEP,IFIN1,2
  253.         IF (ISEG.LE.IFIN2) THEN
  254.           IP1=ICPR(IPT1.NUM(KSEGM(ISEG),IEL))
  255.           IP2=ICPR(IPT1.NUM(KSEGM(ISEG+1),IEL))
  256.         ELSE
  257. C         Polygone
  258.           IP1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),IEL))
  259.           IP2=ICPR(IPT1.NUM(KSEGM(1),IEL))
  260.         ENDIF
  261.         IF (IVU(IP1).NE.1.AND.IVU(IP2).NE.1) GOTO 73
  262.         DSTEL(I)=MIN(DSTEL(I),X(3,IP1),X(3,IP2))
  263.   73  CONTINUE
  264.   72  CONTINUE
  265.       NHZ(1)=1
  266.       NHZ(2)=IFIN-IDEB+1
  267.       IZM=0
  268.       IZ=2
  269.   74  IZ=IZ-1
  270.       IF (IZ.LE.0) GOTO 75
  271.       IPB=NHZ(IZ*2-1)
  272.       IPH=NHZ(IZ*2)
  273.       IF (IPB.GE.IPH) GOTO 74
  274.       JPB=IPB-1
  275.       JPH=IPH+1
  276. C   CALCUL DU PIVOT
  277.       RPV=(DSTEL(IPB+IDEB-1)+DSTEL(IPH+IDEB-1))/2.
  278.   77  JPB=JPB+1
  279.       IF (JPH.EQ.JPB) GOTO 80
  280.       IF (DSTEL(JPB+IDEB-1).GE.RPV) GOTO 78
  281.       GOTO 77
  282.   78  JPH=JPH-1
  283.       IF (JPH.EQ.JPB) GOTO 80
  284.       IF (DSTEL(JPH+IDEB-1).LE.RPV) GOTO 79
  285.       GOTO 78
  286.   79  IAUX=NTELCL(JPH+IDEB-1)
  287.       RAUX=DSTEL(JPH+IDEB-1)
  288.       NTELCL(JPH+IDEB-1)=NTELCL(JPB+IDEB-1)
  289.       DSTEL(JPH+IDEB-1)=DSTEL(JPB+IDEB-1)
  290.       NTELCL(JPB+IDEB-1)=IAUX
  291.       DSTEL(JPB+IDEB-1)=RAUX
  292.       GOTO 77
  293. C   JPH=JPB MAIS ATTENTION PEUT ETRE A L'EXTERIEUR
  294.   80  IF (JPB.GE.IPB) GOTO 81
  295.       JPB=JPB+1
  296.       JPH=JPH+2
  297.       GOTO 84
  298.   81  IF (JPH.LE.IPH) GOTO 82
  299.       JPB=JPB-2
  300.       JPH=JPH-1
  301.       GOTO 84
  302.   82  IF (DSTEL(JPB+IDEB-1).GE.RPV) GOTO 87
  303.       IF (JPH.EQ.IPH) GOTO 83
  304.   86  JPH=JPH+1
  305.       GOTO 84
  306.   87  IF (JPB.EQ.IPB) GOTO 86
  307.   83  JPB=JPB-1
  308.   84  IF (JPB.EQ.IPB) GOTO 85
  309.       NHZ(2*IZ)=JPB
  310.       IZ=IZ+1
  311.   85  IF (JPH.EQ.IPH) GOTO 74
  312.       NHZ(2*IZ)=IPH
  313.       NHZ(2*IZ-1)=JPH
  314.       IZ=IZ+1
  315.       GOTO 74
  316.   75  CONTINUE
  317.   71  CONTINUE
  318. C
  319. C   ON ABORDE MAINTENANT LA BOUCLE ON L'ON BALAYE LES SEGMENTS EN PARTIE
  320. C                            VUS.
  321.       ICOLE=0
  322. C  EN FAIT IL Y A NBCOUL+1 COULEUR (+ EFFACEMENT)
  323.       icoul=-3
  324.       DO 99 ICOLE=0,NBCOUL+1
  325. C PP     kcoul=ICOLE
  326. C+PP  trait blanc
  327.          IF (lblanc) THEN
  328.             kcoul=0
  329.          ELSE
  330.             kcoul=ICOLE
  331.          ENDIF
  332. C+PP
  333.          DO 100 L=1,LTSEG,3
  334.             IPVU=NTSEG(L)
  335.             IPCA=NTSEG(L+1)
  336.             IF (IDEFCO.EQ.1.AND.IICOL.NE.NTSEG(L+2)) GOTO 100
  337.             IF (ICOLE.NE.NTSEG(L+2)) GOTO 100
  338.             IREL=-IVU(IPCA)
  339.             IOB=(IREL-1)/NELEM
  340.             IF (LISOUS(/1).NE.0) THEN
  341.                if (iob.eq.0) goto 100
  342.                IPT1=LISOUS(IOB)
  343.             ELSE
  344.                IPT1=MELEME
  345.             ENDIF
  346.             IEL=IREL-IOB*NELEM
  347.             COXCA=X(1,IPCA)
  348.             COYCA=X(2,IPCA)
  349.             COZCA=X(3,IPCA)
  350.             COXVU=X(1,IPVU)
  351.             COYVU=X(2,IPVU)
  352.             COZVU=X(3,IPVU)
  353.             PARAM=0.9995
  354.             JAC=1
  355.             IOPT=0
  356. *      write (6,*) ' 1 iob,ipt1 ',iob,ipt1
  357.  150        CONTINUE
  358.             LA=0
  359.             ISA=0
  360.             GOTO 2600
  361.  2602       CONTINUE
  362.             IF (ISA.EQ.0) GOTO 151
  363. C   ON VA  BOUCLER POUR ETUDIER LES ELEMENTS QUI TOUCHENT LE
  364. C     SEGMENT ISA ISB
  365. C  ON UTILISE LE TABLEAU KON DES ELEM QUI CONTIENNENT UN POINT
  366.             IOPT=0
  367. *     DO 2500 LA=1,ISUP  PROBLEME ON RENTRE DANS LA BOUCLE EN 2600
  368.             LA=1
  369. 25000       CONTINUE
  370.             LAL=KON(LA,ISA)
  371.             IF (LAL.EQ.0) GOTO 2501
  372.             IF (LAL.EQ.IREL) GOTO 2500
  373. *     DO 2502 LB=1,ISUP  PROBLEME ON RENTRE DANS LA BOUCLE EN 2600
  374.             LB=1
  375. 25020       CONTINUE
  376.             LBL=KON(LB,ISB)
  377.             IF (LBL.EQ.0) GOTO 2503
  378.             IF (LAL.NE.LBL) GOTO 2502
  379.             IF (LBL.EQ.IREL) GOTO 2502
  380.             IREL=LAL
  381.             IOB=(IREL-1)/NELEM
  382.             IF (LISOUS(/1).NE.0) THEN
  383.                IPT1=LISOUS(IOB)
  384.             ELSE
  385.                IPT1=MELEME
  386.             ENDIF
  387.             IEL=IREL-IOB*NELEM
  388. *     write (6,*) ' 2 iob,ipt1 ',iob,ipt1
  389.  2600       CONTINUE
  390. *     write (6,*) ' itypel ',ipt1.itypel
  391.             IDEP=LPT(IPT1.ITYPEL)
  392.             IFIN=IDEP+(LPL(IPT1.ITYPEL)-1)*2
  393.             IFIN2=IFIN
  394.             IF (LPL(IPT1.ITYPEL).EQ.0.AND.LPT(IPT1.ITYPEL).NE.0)THEN
  395. C     Polygone
  396.                IFIN=IDEP+2*IPT1.NUM(/1)-2
  397.                IFIN2=IFIN -2
  398.             ENDIF
  399.             JIC=0
  400.             JOC=0
  401.             DO 101 I=IDEP,IFIN,2
  402.                IF (I.LE.IFIN2) THEN
  403.                   IP1=ICPR(IPT1.NUM(KSEGM(I),IEL))
  404.                   IP2=ICPR(IPT1.NUM(KSEGM(I+1),IEL))
  405.                ELSE
  406. C     Polygone
  407.                   IP1=ICPR(IPT1.NUM(KSEGM(IFIN2+1),IEL))
  408.                   IP2=ICPR(IPT1.NUM(KSEGM(1),IEL))
  409.                ENDIF
  410.                IF (IP1.EQ.IPVU) GOTO 2005
  411.                IF  (IP2.EQ.IPVU) GOTO 2008
  412.                IF (IVU(IP1).NE.1.AND.IVU(IP2).NE.1) GOTO 101
  413.                XIP1=X(1,IP1)
  414.                YIP1=X(2,IP1)
  415.                XIP2=X(1,IP2)
  416.                YIP2=X(2,IP2)
  417. C  ON CALCULE LA COORDONNEE PARAMETRIQUE DU PT INTERSECTION
  418.                DNOM=(COXCA-COXVU)*(YIP2-YIP1)-(COYCA-COYVU)*(XIP2-XIP1)
  419.                IF (DNOM.EQ.0.) GOTO 101
  420.                DNUM=(COYVU-YIP1)*(XIP2-COXVU)-(COYVU-YIP2)*(XIP1-COXVU)
  421.                U=DNUM/DNOM
  422.                FOX=COXVU+U*(COXCA-COXVU)
  423.                FOY=COYVU+U*(COYCA-COYVU)
  424.                IF ((FOX-XIP1)*(FOX-XIP2)+(FOY-YIP1)*(FOY-YIP2).GT.SMO)
  425.      #GOTO 101
  426.                IF (U.LT.-5E-4.OR.U.GT.PARAM) GOTO 101
  427.                JAC=1
  428.                JIC=1
  429.                ISA=IP1
  430.                ISB=IP2
  431.                PARAM=U-5E-4
  432.                IF (PARAM.GT.1E-4) GOTO 101
  433.                GOTO 100
  434.  2005          IF (IP2.EQ.IPCA) GOTO 101
  435.                JOC=1
  436.                GOTO 101
  437.  2008          IF (IP1.EQ.IPCA) GOTO 101
  438.                JOC=1
  439. C  ON NE DESSINE RIEN ?
  440.  101        CONTINUE
  441.             IF (JAC.LE.0) PARAM=PARAM-5E-3
  442.             IF (PARAM.LT.0.) GOTO 100
  443.             COX=COXVU+PARAM*(COXCA-COXVU)
  444.             COY=COYVU+PARAM*(COYCA-COYVU)
  445.             CDIST=COZVU+PARAM*(COZCA-COZVU)
  446.             IF (JOC.NE.0) GOTO 100
  447.             IF (JIC.EQ.0) GOTO 2603
  448.             IF (JAC.EQ.-5) GOTO 2601
  449.             JAC=JAC-1
  450. *  TEST DES ELEMENTS CONTENANT LE SEGMENT
  451.             GOTO 2602
  452.  2603       CONTINUE
  453.             IF (LA.EQ.0) GOTO 2602
  454.  2502       CONTINUE
  455.             LB=LB+1
  456.             IF (LB.LE.ISUP) GOTO 25020
  457.  2503       CONTINUE
  458.  2500       CONTINUE
  459.             LA=LA+1
  460.             IF (LA.LE.ISUP) GOTO 25000
  461.  2501       CONTINUE
  462. *  PLUS D'ELEMENT TESTABLE RECHERCHE FINALE
  463. C  REGARDONS SI UN ELEMENT CACHE CE POINT
  464. C    D'ABORD TROUVONS SA ZONE
  465. C   ON BOUCLE SUR TOUS LES ELEMENTS
  466.  151        CONTINUE
  467.             IF (IOPT.EQ.1) GOTO 100
  468.             KNN=INT(real((COX-XMIN)/XDEC))+1+INT(real((COY-YMIN)/YDEC))
  469.      $           *NDEC
  470.             IOPT=1
  471.             DO 140 IBAL=1,10
  472.                GOTO (130,131,132,133,134,135,136,137,138,139),IBAL
  473.  130           KN=KNN
  474.                GOTO 110
  475.  131           KN=KNN-1+NBZONE+1
  476.                GOTO 110
  477.  132           KN=KNN+(NBZONE)+1
  478.                GOTO 110
  479.  133           KN=KNN-NDEC+(NBZONE+1)+(NBZONE+NDEC)
  480.                GOTO 110
  481.  134           KN=KNN+(NBZONE+1)+(NBZONE+NDEC)
  482.                GOTO 110
  483.  135           KN=KNN+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1)
  484.                GOTO 110
  485.  136           KN=KNN-1+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1)
  486.                GOTO 110
  487.  137           KN=KNN-NDEC+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1)
  488.                GOTO 110
  489.  138           KN=KNN-NDEC-1+(NBZONE+1)+(NBZONE+NDEC)+(NBZONE+NDEC+1)
  490.                GOTO 110
  491.  139           KN=0
  492.                GOTO 110
  493.  110           KPU=IJK(KN+1+1)
  494.                KPV=IJK(KN+1)+1
  495.                IF (KPU.LT.KPV) GOTO 140
  496.                IELD=1
  497.                DO 112 KK=KPV,KPU
  498.                   IF (IELD.EQ.0) GOTO 140
  499.                   IELD=0
  500.                   IF (DSTEL(KK).GE.CDIST) GOTO 140
  501.                   IREL=NTELCL(KK)
  502.                   IOB=(IREL-1)/NELEM
  503.                   IF (LISOUS(/1).NE.0) THEN
  504.                      IPT1=LISOUS(IOB)
  505.                   ELSE
  506.                      IPT1=MELEME
  507.                   ENDIF
  508.                   K=IREL-IOB*NELEM
  509.                   NBFAC=LTEL(1,IPT1.ITYPEL)
  510.                   IAD=LTEL(2,IPT1.ITYPEL)-1
  511.                   IDEDAF=0
  512.                   DO 116 IFAC=1,NBFAC
  513.                      ITYP=LDEL(1,IAD+IFAC)
  514.                      JAD=LDEL(2,IAD+IFAC)-1
  515.                      IDEP=KDFAC(2,ITYP)
  516.                      IFEP=IDEP+3*(KDFAC(3,ITYP)-1)
  517.                      IDEDAN=0
  518.                      DO 115 ITRIAN=IDEP,IFEP,3
  519.                         IA=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN)),K))
  520.                         IB=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN+1)),K))
  521.                         IC=ICPR(IPT1.NUM(LFAC(JAD+KFAC(ITRIAN+2)),K))
  522.                         ZA=X(3,IA)
  523.                         ZB=X(3,IB)
  524.                         ZC=X(3,IC)
  525.                         IF (ZA.LT.CDIST) GOTO 201
  526.                         IF (ZB.LT.CDIST) GOTO 201
  527.                         IF (ZC.LT.CDIST) GOTO 201
  528.                         GOTO 123
  529.  201                    IELD=1
  530.                         IF (IVU(IA).EQ.1) GOTO 200
  531.                         IF (IVU(IB).EQ.1) GOTO 200
  532.                         IF (IVU(IC).EQ.1) GOTO 200
  533.                         GOTO 123
  534.  200                    IF (IA.EQ.IPVU) GOTO 202
  535.                         IF (IB.EQ.IPVU) GOTO 202
  536.                         IF (IC.EQ.IPVU) GOTO 202
  537.                         GOTO 203
  538.  202                    IF (IA.EQ.IPCA) GOTO 123
  539.                         IF (IB.EQ.IPCA) GOTO 123
  540.                         IF (IC.EQ.IPCA) GOTO 123
  541.  203                    CONTINUE
  542.                         VAX=COX-X(1,IA)
  543.                         VAY=COY-X(2,IA)
  544.                         VBX=COX-X(1,IB)
  545.                         VBY=COY-X(2,IB)
  546.                         VCX=COX-X(1,IC)
  547.                         VCY=COY-X(2,IC)
  548.                         DC=VAX*VBY-VAY*VBX
  549.                         DA=VBX*VCY-VBY*VCX
  550.                         IF (DA*DC.LT.0.) GOTO 123
  551.                         DB=VCX*VAY-VCY*VAX
  552.                         IF (DA*DB.LT.0.) GOTO 123
  553.                         IF (DC*DB.LT.0.) GOTO 123
  554.                         IF (ABS(DA).GT.SMO) GOTO 121
  555.                         IF (ABS(DB).GT.SMO) GOTO 121
  556.                         IF (ABS(DC).GT.SMO) GOTO 121
  557.                         IF (VAX*VBX.LT.-SMO) GOTO 123
  558.                         IF (VAX*VCX.LT.-SMO) GOTO 123
  559.                         IF (VAY*VCY.LT.-SMO) GOTO 123
  560.                         IF (VAY*VBY.LT.-SMO) GOTO 123
  561.                         IF (VBX*VCX.LT.-SMO) GOTO 123
  562.                         IF (VBY*VCY.LT.-SMO) GOTO 123
  563.  121                    CONTINUE
  564.                         S=DA+DB+DC
  565.                         IF (S.EQ.0.) GOTO 123
  566.                         DA=DA/S
  567.                         DB=DB/S
  568.                         DC=DC/S
  569.                         S=DA*ZA+DB*ZB+DC*ZC
  570.                         IF (S.GT.CDIST) GOTO 123
  571.                         IDEDAN=IDEDAN+1
  572.  123                    CONTINUE
  573.  115                 CONTINUE
  574.                      idedaf = idedaf + mod(idedan,2)
  575.  116              CONTINUE
  576.                   IF (IDEDAf.ne.0) THEN
  577. C     ON EST CACHE PAR L'ELEMENT K
  578.                      IF (IIMPI.NE.0) WRITE (IOIMP,9923) K
  579.  9923                FORMAT(' LIGNE CACHE PAR ',I6)
  580.                      IEL=K
  581.                      GOTO 150
  582.                   ENDIF
  583.  112           CONTINUE
  584.  140        CONTINUE
  585. C     ON EST DESORMAIS VU. LE TRAIT S'ARRETE DONC LA
  586.  2601       CONTINUE
  587. *SG 20160420
  588.             if (kcoul.ne.icoul) then
  589.                call chcoul(kcoul)
  590.                icoul=kcoul
  591.             endif
  592.             XTR(1)=X(1,IPVU)
  593.             YTR(1)=X(2,IPVU)
  594.             XTR(2)=COX
  595.             YTR(2)=COY
  596.             CALL POLRL(2,XTR,YTR,ZTR)
  597.  100     CONTINUE
  598.  99   CONTINUE
  599.       SEGSUP TRAV5,TRAV2,NTSEG,TRAV4
  600.       END
  601.  
  602.  
  603.  
  604.  
  605.  

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