Télécharger la plaquette Cast3M


fr en

Télécharger transf.eso

Retour à la liste

Numérotation des lignes : 

transf

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

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