Télécharger la plaquette Cast3M


fr en

Télécharger j3coup.eso

Retour à la liste

Numérotation des lignes : 

j3coup

  1. C J3COUP    SOURCE    CHAT      05/01/13    00:46:14     5004
  2.       SUBROUTINE J3COUP(WWORK1,WORK2,VWORK1,VWORK2,IRED,TOL,IRET)
  3. C----------------------------------------------------
  4. C     COUPURE DES FACES A ET B
  5. C
  6. C     CODE IST(1,I): 0 point non traite
  7. C                    1 est sur le segment IST(2,I)
  8. C                    2 est sur les segments IST(2,I) et IST(3,I)
  9. C                   -1 est a l'interieur
  10. C                   -2 est a l'exterieur
  11. C
  12. C     CODE CRO(J,I): 1 cote sur le segment
  13. C                   -1 cote interieur
  14. C                   -2 cote exterieur
  15. C
  16. C     IRED=0 EMPECHE LA REDISTRIBUTION DES TROUS
  17. C
  18. C     PP 6/97,11/98
  19. C     Pierre Pegon/JRC Ispra
  20. C----------------------------------------------------
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. C
  26.       SEGMENT WORK
  27.         REAL*8 XYC(2,NPTO)
  28.         INTEGER IST(3,NPTO)
  29.         REAL*8 DENS(NPTO)
  30.         INTEGER JUN
  31.       ENDSEGMENT
  32.       POINTEUR WORK1.WORK,WORK2.WORK
  33. C
  34.       SEGMENT WWORK
  35.         REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  36.         INTEGER FWORK
  37.         INTEGER TWORK(NTROU)
  38.       ENDSEGMENT
  39.       SEGMENT WWORK1.WWORK
  40. C
  41.       SEGMENT VWORK
  42.         INTEGER FWWORK(NFACE)
  43.       ENDSEGMENT
  44.       SEGMENT VWORK1.VWORK,VWORK2.VWORK
  45. C
  46.       SEGMENT JUNC
  47.         INTEGER CRO(2,NPTO)
  48.       ENDSEGMENT
  49.       SEGMENT JUNC1.JUNC,JUNC2.JUNC
  50. C
  51.       LOGICAL LAINB,LAOUB,LAONB
  52. C
  53.       IF (IIMPI.EQ.1789)THEN
  54.         WRITE(IOIMP,*)'>>> On entre dans j3coup <<<'
  55.       ENDIF
  56. C
  57.       WORK1=WWORK1.FWORK
  58. C
  59. C     ON CHERCHE LE NB D'INTERSECTION AVEC B
  60. C
  61.       NPTO1=WORK1.XYC(/2)
  62.       JUNC1=WORK1.JUN
  63.       NPTO2=WORK2.XYC(/2)
  64.       JUNC2=WORK2.JUN
  65. C
  66.       NINTER=0
  67.       DO IE1=1,NPTO1
  68.         ISU=WORK1.IST(1,IE1)
  69.         IF(ISU.GT.0)THEN
  70.           CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,I2)
  71.           ICRO2=JUNC2.CRO(1,I2)
  72.           ICRP2=JUNC2.CRO(2,I2)
  73.           IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN
  74.             NINTER=NINTER+1
  75.             IF(ICRO2+ICRP2.EQ.-2)THEN
  76.               NINTER=NINTER+1
  77.             ENDIF
  78.           ENDIF
  79.         ENDIF
  80.       ENDDO
  81. C
  82. C     NINTER DOIT ETRE UN MULTIPLE DE 2
  83. C
  84.       NFAC1=NINTER/2
  85.       IF(NINTER-2*NFAC1.NE.0)THEN
  86.         IRET=IRET+1
  87.         WRITE(IOIMP,*)'J3COUP: LE NOMBRE D"INTERSECTIONS DOIT ETRE PAIR'
  88.         RETURN
  89.       ENDIF
  90.       NFAC1=NFAC1+1
  91. C
  92. C     ON PREPARE QUI VA RECEVOIR LES FACES
  93. C
  94.       NFACE=NFAC1
  95.       SEGINI,VWORK1,VWORK2
  96.       IFAC1=0
  97.       IFAC2=0
  98. C
  99. C     ON LOOP SUR LES FACES
  100. C
  101.       IPLA1=1
  102.       DO IE0=1,NFAC1
  103. C
  104. C     ON CHERCHE LE DEBUT D'UNE INTERSECTION AVEC B
  105. C
  106.         DO IE1=IPLA1,NPTO1
  107.           ISU=WORK1.IST(1,IE1)
  108.           IF(ISU.GT.0)THEN
  109.             CALL J3NUMP(WORK1.IST(1,IE1),NPTO2,I2)
  110.             ICRO2=JUNC2.CRO(1,I2)
  111.             ICRP2=JUNC2.CRO(2,I2)
  112.             IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN
  113.               GOTO 1
  114.             ENDIF
  115.           ENDIF
  116.         ENDDO
  117. C >>>>>>>>>>>>> A VOIR SI IL NE FAUT PAS ALORS METTRE B!
  118.         IF(IE0.EQ.NFAC1)GOTO 5
  119.         IRET=IRET+1
  120.         WRITE(IOIMP,*)'J3COUP: LE NOMBRE DE BLOCKS N"EST PAS ATTEINT'
  121.         RETURN
  122. C >>>>>>>>>>>>> A VOIR SI IL NE FAUT PAS ALORS METTRE B!
  123. C
  124. C     ON FORME UN NOUVEAU BLOCK EN CIRCULANT SUR B ET A TJS VERS
  125. C     L'INTERIEUR, EN INVALIDANT LES INTERSECTION DE A AU FUR ET A
  126. C     MESURE QUE ON LES RENCONTRE, ET JUSQU'A FERMETURE
  127. C
  128. C     A) ON STOCKE LE PREMIER POINT DE LA NOUVELLE FACE ...
  129. C
  130.  1      CONTINUE
  131.         IPLA1=IE1
  132.         I1=IPLA1
  133. C
  134.         NPTO=NPTO1+NPTO2
  135.         SEGINI,WORK
  136.         JUN=0
  137.         IPTO=1
  138.         DO IE2=1,2
  139.           XYC(IE2,IPTO)=WORK1.XYC(IE2,IPLA1)
  140.         ENDDO
  141.         DENS(IPTO)=WORK1.DENS(IPLA1)
  142. C
  143. C     B) ... PUIS ON L'INVALIDE
  144. C        (PT DE BRANCHEMENT EN CAS DE PARCOURS MULTIPLE)
  145. C
  146.  2      CONTINUE
  147.         WORK1.IST(1,I1)=0
  148. C
  149. C     C) ON INITIALISE ENSUITE LE PARCOURS SUR B
  150. C        "SENS DE LA NUMEROTATION" +1 ou -1 ?
  151. C        FACILE SAUF EN CAS D'INTER MULTIPLE
  152. C
  153.         IF(ICRO2+ICRP2.EQ.-2)THEN
  154.           CALL J3ANG1(WORK1.XYC,NPTO1,I1,WORK2.XYC,NPTO2,I2,TOL,AG1,AG2)
  155.           IF(ABS(AG1).LT.ABS(AG2))THEN
  156.             ISEN2=-1
  157.           ELSE
  158.             ISEN2=+1
  159.           ENDIF
  160.         ELSE
  161.           IF(ICRO2.EQ.-1)THEN
  162.             ISEN2=-1
  163.           ELSE
  164.             ISEN2=+1
  165.           ENDIF
  166.         ENDIF
  167. C
  168. C     D) ON RESTE SUR B JUSQU'AU CONTACT AVEC A
  169. C        ON REVIENT ALORS SUR A SAUF SI IL Y A 2 COTE INTERIEUR ET QUE
  170. C        ON LE PARCOURT DANS LE SENS + (DEDANS!)
  171. C
  172.         DO IE2=1,NPTO2
  173.           I2=I2+ISEN2
  174.           IF((I2.LT.1).OR.(I2.GT.NPTO2))I2=I2-ISEN2*NPTO2
  175. C
  176.           IPTO=IPTO+1
  177.           DO IE3=1,2
  178.             XYC(IE3,IPTO)=WORK2.XYC(IE3,I2)
  179.           ENDDO
  180.           DENS(IPTO)=WORK2.DENS(I2)
  181. C
  182.           ISU=WORK2.IST(1,I2)
  183.           IF(ISU.GT.0)THEN
  184.             ICRO2=JUNC2.CRO(1,I2)
  185.             ICRP2=JUNC2.CRO(2,I2)
  186.             IF((ISEN2.EQ.-1).OR.(ICRO2.NE.-1).OR.(ICRP2.NE.-1))GOTO 3
  187.           ENDIF
  188. C
  189.         ENDDO
  190. C
  191.         IRET=IRET+1
  192.         WRITE(IOIMP,*)'J3COUP: ON NE PEUT PAS CIRCULER TJS SUR B!'
  193.         RETURN
  194. C
  195.  3      CONTINUE
  196. C
  197. C     E) ON INITIALISE LE PARCOURS SUR A (LE SENS DE PARCOURS EST TJ +1!)
  198. C
  199.         CALL J3NUMP(WORK2.IST(1,I2),NPTO1,I1)
  200.         DO IE2=1,NPTO1
  201. C
  202.           I1=I1+1
  203.           IF(I1.GT.NPTO1)I1=I1-NPTO1
  204.           IF(I1.EQ.IPLA1)GOTO 4
  205. C
  206.           IPTO=IPTO+1
  207.           DO IE3=1,2
  208.             XYC(IE3,IPTO)=WORK1.XYC(IE3,I1)
  209.           ENDDO
  210.           DENS(IPTO)=WORK1.DENS(I1)
  211. C
  212.           ISU=WORK1.IST(1,I1)
  213.           IF(ISU.GT.0)THEN
  214.             CALL J3NUMP(WORK1.IST(1,I1),NPTO2,I2)
  215.             ICRO2=JUNC2.CRO(1,I2)
  216.             ICRP2=JUNC2.CRO(2,I2)
  217.             IF((ICRO2.EQ.-1).OR.(ICRP2.EQ.-1))THEN
  218.               GOTO 2
  219.             ENDIF
  220.           ENDIF
  221. C
  222.         ENDDO
  223. C
  224.         IRET=IRET+1
  225.         WRITE(IOIMP,*)'J3COUP: ON NE PEUT PAS CIRCULER TJS SUR A!'
  226.         RETURN
  227. C
  228. C     F) LA FACE WORK EST FINIE, ON LA STOCKE SOIT DANS VWORK1 (FACES
  229. C        INTERIEURES A B) SOIT DANS VWORK2 (FACES EXTERIEURES A B)
  230. C        WARNING: SI LA FACE INTE A B EST EGALE A B, ON LA
  231. C                 REND IDENTIQUE A B
  232. C
  233.  4      CONTINUE
  234. C
  235.         NPTO=IPTO
  236.         SEGADJ,WORK
  237. C
  238.         NTROU=0
  239.         SEGINI,WWORK
  240.         IF (ISEN2.EQ.+1)THEN
  241.           IFAC1=IFAC1+1
  242.           VWORK1.FWWORK(IFAC1)=WWORK
  243.           CALL J3IDEN(WORK,WORK2,TOL)
  244.         ELSE
  245.           IFAC2=IFAC2+1
  246.           VWORK2.FWWORK(IFAC2)=WWORK
  247.         ENDIF
  248.         FWORK=WORK
  249.         IF(IFAC1+IFAC2.EQ.NFAC1)GOTO 6
  250. C
  251. C     FIN LOOP SUR LES FACES
  252. C
  253.       ENDDO
  254. C
  255. C     CAS OU B EST LA DERNIERE FACE (C'EST ALORS L'UNIQUE FACE INTE!)
  256. C
  257.  5    CONTINUE
  258.       IF(IFAC1.NE.0)THEN
  259.         IRET=IRET+1
  260.         WRITE(IOIMP,*)'J3COUP: B NE PEUT ETRE QUE L"UNIQUE FACE INTE'
  261.         RETURN
  262.       ENDIF
  263.       SEGINI,WORK=WORK2
  264.       JUN=0
  265.       NTROU=0
  266.       SEGINI,WWORK
  267.       FWORK=WORK
  268.       IFAC1=IFAC1+1
  269.       VWORK1.FWWORK(IFAC1)=WWORK
  270. C
  271. C     ON AJUSTE VWORK1 ET VWORK2
  272. C
  273.  6    CONTINUE
  274.       NFACE=IFAC1
  275.       SEGADJ,VWORK1
  276.       NFACE=IFAC2
  277.       SEGADJ,VWORK2
  278. C
  279. C     ON VA MAINTENANT DISTRIBUER LES TROU DE A (DANS LES FACES EXTE
  280. C     A B (INHIBE SI IRED=0)
  281. C
  282.       IF(IRED.EQ.0)RETURN
  283. C
  284. C     A) Y-A-T'IL DES TROUS DANS A
  285. C
  286.       NTROU1=WWORK1.TWORK(/1)
  287.       IF(NTROU1.EQ.0)RETURN
  288. C
  289. C     B) ON LOOP SUR LES TROUS DE A QUE L'ON PLACE DANS WORK1
  290. C
  291.       DO 11 IE1=1,NTROU1
  292.         WORK1=WWORK1.TWORK(IE1)
  293.         IF(WORK1.EQ.0)GOTO 11
  294. C
  295. C     C) ON LOOP SUR LES FACES DE VWORK2 QUE L'ON PLACE DANS WORK2
  296. C
  297.         DO IE2=1,NFACE
  298.           WWORK=VWORK2.FWWORK(IE2)
  299.           WORK2=FWORK
  300. C
  301. C     D) LE TROU WORK1 EST-IL DANS LA FACE WORK2 (TEST MINIMUM)?
  302. C
  303.           CALL J3COTO(WORK1,WORK2,TOL,IRET)
  304.           IF (IRET.GT.0)THEN
  305.             RETURN
  306.           ENDIF
  307.           NPTO1=WORK1.XYC(/2)
  308.           CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  309. C
  310. C     E) SI OUI, ON LE MET DANS LA FACE ET ON LE RETIRE DE A
  311. C
  312. C>>>>>>>>>>>> .NOT.LAINB EN PLUS ??????
  313.           IF(.NOT.LAOUB)THEN
  314.             NTROU=TWORK(/1)
  315.             NTROU=NTROU+1
  316.             SEGADJ,WWORK
  317.             TWORK(NTROU)=WORK1
  318.             WWORK1.TWORK(IE1)=0
  319.             GOTO 10
  320. C
  321.           ENDIF
  322.         ENDDO
  323.  10     CONTINUE
  324.  11   CONTINUE
  325. C
  326. C     F) ON VERIFIE QUE TOUS LES TROUS DE A ONT ETE DISTRIBUES
  327. C
  328.       DO IE1=1,NTROU1
  329.         IF(WWORK1.TWORK(IE1).NE.0)THEN
  330.           IRET=IRET+1
  331.           WRITE(IOIMP,*)'J3COUP: TOUS LES TROUS DE A AURAIENT DUS ETRE'
  332.           WRITE(IOIMP,*)'        DIDTRIBUES'
  333.           RETURN
  334.         ENDIF
  335.       ENDDO
  336. C
  337.       RETURN
  338.       END
  339.  
  340.  
  341.  

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