Télécharger la plaquette Cast3M


fr en

Télécharger msche1.eso

Retour à la liste

Numérotation des lignes : 

msche1

  1. C MSCHE1    SOURCE    OF166741  24/10/03    21:15:26     12022          
  2.       SUBROUTINE MSCHE1(IPCHE2,IPCHE3,X1,IKO,IPCHE1,ICLE,IPCHMA,ISOM,
  3.      &                  IRET)
  4. *****************************************************************
  5. *            OPERATEUR MASQ
  6. *
  7. *  ENTREES :
  8. *  ---------
  9. *     IPCHE1   :POINTEUR SUR LE PREMIER CHAMELEM
  10. *     IPCHE2   :POINTEUR SUR UN SECOND CHAMELEM
  11. *     IPCHE3   :POINTEUR SUR UN TROISIEME CHAMELEM (OPTION "COMP")
  12. *     X1       :VALEUR MIN OU MAX (OPTION "COMP")
  13. *     IKO      :0 SI IPCHE2 PUIS IPCHE3
  14. *               1 SI X1 PUIS IPCHE2
  15. *              -1 SI IPCHE2 PUIS X1
  16. *     ICLE     :ENTIER CARACTERISANT LE TYPE DE COMPARAISON
  17. *     ISOM     =1 SI ON VEUT LA SOMME
  18. *              =0 SINON
  19. *
  20. *  SORTIE :
  21. *  --------
  22. *     IPCHMA   :- POINTEUR SUR LE CHAMELEM RESULTAT SI ISOM=0
  23. *               - SOMME DES 1 ET DES 0  SI OPTION ISOM=1
  24. *     IRET     =1 OU 0 SUIVANT SUCCES OU PAS
  25. *
  26. *  PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 01/91
  27. *
  28. *****************************************************************
  29.       IMPLICIT INTEGER(I-N)
  30.       IMPLICIT REAL*8(A-H,O-Z)
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC SMCHAML
  35. -INC SMLREEL
  36. -INC SMCOORD
  37. -INC SMELEME
  38. -INC SMINTE
  39.  
  40.       CHARACTER*4 MOK
  41.       CHARACTER*16 CONCH1,CONCH2,CONCH3
  42.       CHARACTER*72 TIT1,TIT2,TIT3,TITC
  43.       PARAMETER (NINF=3)
  44.       INTEGER INFOS(NINF)
  45.  
  46.       SEGMENT MTRAA
  47.          INTEGER ITRAA(LX)
  48.       ENDSEGMENT
  49.       SEGMENT MTRAA2
  50.          INTEGER ITRAA2(LX)
  51.       ENDSEGMENT
  52.  
  53.       IKOK=IKO
  54.       IF (IKOK.EQ.0.AND.IPCHE3.LE.0) IKOK=-1
  55.  
  56.       IRET = 0
  57. *
  58. *     POUR INFERIEUR  ,IDEM SUPERIEUR EN INVERSANT IPCHE1 ET IPCHE2
  59. *
  60.       IF (ICLE.EQ.4.OR.ICLE.EQ.5) THEN
  61.         IKKK=IPCHE2
  62.         IPCHE2=IPCHE1
  63.         IPCHE1=IKKK
  64.         IF (ICLE.EQ.4) ICLE=2
  65.         IF (ICLE.EQ.5) ICLE=1
  66.       ENDIF
  67.  
  68.       JPCHE1=IPCHE1
  69.       JPCHE2=IPCHE2
  70.       JPCHE3=IPCHE3
  71. *
  72. *     ==========================================================
  73. *     ON TESTE D'ABORD LA COMPATIBILITE ENTRE LES MCHAML FOURNIS
  74. *     ==========================================================
  75.  
  76.       MCHEL1 = IPCHE1
  77.       MCHEL2 = IPCHE2
  78.  
  79.       IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
  80.         CALL ERREUR(103)
  81.         GOTO 666
  82.       ENDIF
  83.  
  84.       CALL CALPAQ(IPCHE1,IPCHE2,K,TITC,NUMCHA,iretou)
  85.       IF (iretou.EQ.0) GOTO 666
  86. *
  87. * -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  88.       IPCHE1=JPCHE1
  89.       IPCHE2=JPCHE2
  90. *
  91.       IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN
  92.         CALL ERREUR(488)
  93.         GOTO 666
  94.       ENDIF
  95.  
  96.       MCHEL1 = IPCHE1
  97.       MCHEL2 = IPCHE2
  98.       TIT1 = MCHEL1.TITCHE
  99.       TIT2 = MCHEL2.TITCHE
  100.       IF (K.EQ.5.AND.(TIT1.NE.TIT2) ) THEN
  101.          CALL ERREUR(21)
  102.          GOTO 666
  103.       ENDIF
  104.       NSOUS1 = MCHEL1.ICHAML(/1)
  105.       NSOUS2 = MCHEL2.ICHAML(/1)
  106.       IF (NSOUS1.NE.NSOUS2) THEN
  107.         CALL ERREUR(103)
  108.         GOTO 666
  109.       ENDIF
  110. *
  111. *        QUELLE BIJECTION ENTRE LES SOUS PAQUETS DE MCHEL1 ET DE MCHEL2
  112. *
  113.       LX=NSOUS1
  114.       SEGINI MTRAA
  115. *
  116.       DO 110 ISOUS1=1,NSOUS1
  117.          IPMAI1=MCHEL1.IMACHE(ISOUS1)
  118.          CONCH1=MCHEL1.CONCHE(ISOUS1)
  119.          DO 120 ISOUS2=1,NSOUS2
  120.             IPMAI2=MCHEL2.IMACHE(ISOUS2)
  121.             CONCH2=MCHEL2.CONCHE(ISOUS2)
  122.             IF (IPMAI1.NE.IPMAI2.OR.CONCH1.NE.CONCH2) GOTO 120
  123.             CALL IDENT(IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
  124.             IF (IRTD.EQ.0) GOTO 120
  125.  
  126.             IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  127.             IMINT2=MCHEL2.INFCHE(ISOUS2,4)
  128.             IF (IMINT1.EQ.IMINT2) GOTO 121
  129.  
  130.             IMINT1= MCHEL1.INFCHE(ISOUS1,6)
  131.             IMINT2= MCHEL2.INFCHE(ISOUS2,6)
  132.             IF (IMINT1.EQ.IMINT2) GOTO 121
  133. *
  134.             SEGSUP MTRAA
  135. *
  136. *           ERREUR PAS DE CORRESPONDANCE 2 A 2
  137. *
  138.             CALL ERREUR(103)
  139.             GOTO 666
  140. *
  141.  120     CONTINUE
  142. *
  143.  121     CONTINUE
  144.          ITRAA(ISOUS1)=ISOUS2
  145.          GOTO 110
  146.   110 CONTINUE
  147.  
  148. *     SI BESOIN ON FAIT LES MEMES TESTS AVEC LE TROISIEME MCHAML
  149. *     (OPTION "COMP")
  150.       IF (IKOK.EQ.0) THEN
  151.          MCHEL3 = IPCHE3
  152.  
  153.          IF (MCHEL1.IFOCHE.NE.MCHEL3.IFOCHE) THEN
  154.             CALL ERREUR(103)
  155.             GOTO 666
  156.          ENDIF
  157.  
  158.          CALL CALPAQ(IPCHE1,IPCHE3,K,TITC,NUMCHA,iretou)
  159.          IF (iretou.EQ.0) GOTO 666
  160. *
  161. *       -> CALPAQ peut avoir permute les pointeurs mais ils sont toujours ACTIFs
  162.          IPCHE1=JPCHE3
  163.          IPCHE3=JPCHE3
  164. *
  165.          IF (K.NE.1.AND.K.NE.3.AND.K.NE.5) THEN
  166.          CALL ERREUR(488)
  167.          GOTO 666
  168.          ENDIF
  169.  
  170.          MCHEL3 = IPCHE3
  171.          TIT3 = MCHEL3.TITCHE
  172.          IF (K.EQ.5.AND.(TIT1.NE.TIT3) ) THEN
  173.             CALL ERREUR(21)
  174.             GOTO 666
  175.          ENDIF
  176.          NSOUS3 = MCHEL3.ICHAML(/1)
  177.          IF (NSOUS1.NE.NSOUS3) THEN
  178.          CALL ERREUR(103)
  179.          GOTO 666
  180.          ENDIF
  181.  
  182.          LX=NSOUS1
  183.          SEGINI MTRAA2
  184.          DO 150 ISOUS1=1,NSOUS1
  185.            IPMAI1=MCHEL1.IMACHE(ISOUS1)
  186.            CONCH1=MCHEL1.CONCHE(ISOUS1)
  187.            DO 160 ISOUS3=1,NSOUS3
  188.              IPMAI3=MCHEL3.IMACHE(ISOUS3)
  189.              CONCH3=MCHEL3.CONCHE(ISOUS3)
  190.              IF (IPMAI1.NE.IPMAI3.OR.CONCH1.NE.CONCH3) GOTO 160
  191.              CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE3,INFOS,IRTD)
  192.              IF (IRTD.EQ.0) GOTO 160
  193. *
  194.              IMINT1=MCHEL1.INFCHE(ISOUS1,4)
  195.              IMINT3=MCHEL3.INFCHE(ISOUS3,4)
  196.              IF (IMINT1.EQ.IMINT3) GOTO 151
  197. *
  198.              IMINT1=MCHEL1.INFCHE(ISOUS1,6)
  199.              IMINT3=MCHEL3.INFCHE(ISOUS3,6)
  200.              IF (IMINT1.EQ.0) IMINT1=1
  201.              IF (IMINT3.EQ.0) IMINT3=1
  202.              IF (IMINT1.EQ.IMINT3) GOTO 151
  203. *
  204.              SEGSUP MTRAA2
  205. *
  206. *            ERREUR PAS DE CORRESPONDANCE 2 A 2
  207. *
  208.              CALL ERREUR(103)
  209.              GOTO 666
  210. *
  211.  160       CONTINUE
  212. *
  213.  151       CONTINUE
  214.            ITRAA2(ISOUS1)=ISOUS3
  215.            GOTO 150
  216.   150    CONTINUE
  217.  
  218.       ENDIF
  219.  
  220. *     ======================================
  221. *     ON FAIT LA COMPARAISON PROPREMENT DITE
  222. *     ======================================
  223.  
  224.       KSOM=0
  225.       NSOUS=NSOUS1
  226.       N1=NSOUS
  227.       N3=MCHEL1.INFCHE(/2)
  228.       L1=MCHEL1.TITCHE(/1)
  229.       SEGINI MCHELM
  230.       IPCHMA=MCHELM
  231.       IFOCHE=MCHEL1.IFOCHE
  232.       TITCHE=TIT1
  233. *
  234. *     BOUCLE  SUR LES SOUS PAQUETS DE MCHELM
  235. *
  236.       DO 200 ISOUS=1,NSOUS
  237.          DO 201 N33=1,N3
  238.             INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
  239.  201     CONTINUE
  240.          IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
  241.          CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
  242. *
  243.          ISOUS2=ITRAA(ISOUS)
  244. *
  245.          MCHAM1=MCHEL1.ICHAML(ISOUS )
  246.          MCHAM2=MCHEL2.ICHAML(ISOUS2)
  247.  
  248.          IF (IKOK.EQ.0) THEN
  249.             ISOUS3=ITRAA2(ISOUS)
  250.             MCHAM3=MCHEL3.ICHAML(ISOUS3)
  251.          ENDIF
  252. *
  253.             meleme = imache(isous)
  254.             nnel = num(/2)
  255.             if (infche(isous,4).eq.0) then
  256.               nnptel = num(/1)
  257.             else
  258.               minte = infche(isous,4)
  259.               nnptel = qsigau(/1)
  260.             endif
  261. *
  262.          NCOMP=MCHAM1.IELVAL(/1)
  263.          N2=NCOMP
  264.          SEGINI MCHAML
  265.          ICHAML(ISOUS)=MCHAML
  266.          DO 300 ICOMP=1,NCOMP
  267.             CALL PLACE ( MCHAM2.NOMCHE,MCHAM2.IELVAL(/1),IPLAC,
  268.      &                   MCHAM1.NOMCHE(ICOMP) )
  269. *
  270.             IF (IPLAC.EQ.0) THEN
  271.                MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  272.                MOTERR(5:8)=TIT1(1:4)
  273.                CALL ERREUR(77)
  274.                SEGSUP MCHAML,MCHELM,MTRAA
  275.                GOTO 666
  276.             ENDIF
  277.  
  278.             NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP)
  279.             TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP)
  280. *
  281.             MELVA1=MCHAM1.IELVAL(ICOMP)
  282.             MELVA2=MCHAM2.IELVAL(IPLAC)
  283. *
  284.             IF (IKOK.EQ.0) THEN
  285.                CALL PLACE ( MCHAM3.NOMCHE,MCHAM3.IELVAL(/1),IPLAC2,
  286.      &                      MCHAM1.NOMCHE(ICOMP) )
  287. *
  288.                IF (IPLAC2.EQ.0) THEN
  289.                   MOTERR(1:4)=MCHAM1.NOMCHE(ICOMP)
  290.                   MOTERR(5:8)=TIT1(1:4)
  291.                   CALL ERREUR(77)
  292.                   SEGSUP MCHAML,MCHELM,MTRAA
  293.                   GOTO 666
  294.                ENDIF
  295. *
  296.                MELVA3=MCHAM3.IELVAL(IPLAC2)
  297.             ENDIF
  298. *
  299.             IF (MCHAM1.TYPCHE(ICOMP).EQ.'REAL*8') THEN
  300.                NBPTE1=MELVA1.VELCHE(/1)
  301.                NEL1  =MELVA1.VELCHE(/2)
  302.                NBPTE2=MELVA2.VELCHE(/1)
  303.                NEL2  =MELVA2.VELCHE(/2)
  304.                NBPGAU=MAX(NBPTE1,NBPTE2)
  305.                NBELEM=MAX(NEL1,NEL2)
  306.                IF (IKOK.EQ.0) THEN
  307.                   NBPTE3=MELVA3.VELCHE(/1)
  308.                   NEL3  =MELVA3.VELCHE(/2)
  309.                   NBPGAU=MAX(NBPTE1,NBPTE3)
  310.                   NBELEM=MAX(NEL1,NEL3)
  311.                ENDIF
  312. *
  313.                N2PTEL=0
  314.                N2EL  =0
  315.                N1PTEL=NBPGAU
  316.                N1EL  =NBELEM
  317. *
  318.                IML=0
  319.             ELSE IF (MCHAM1.TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
  320.                NBPTE1=MELVA1.IELCHE(/1)
  321.                NEL1  =MELVA1.IELCHE(/2)
  322.                NBPTE2=MELVA2.IELCHE(/1)
  323.                NEL2  =MELVA2.IELCHE(/2)
  324.                NBPGAU=MAX(NBPTE1,NBPTE2)
  325.                NBELEM=MAX(NEL1,NEL2)
  326.                IF (IKOK.EQ.0) THEN
  327.                   NBPTE3=MELVA3.VELCHE(/1)
  328.                   NEL3  =MELVA3.VELCHE(/2)
  329.                   NBPGAU=MAX(NBPTE1,NBPTE3)
  330.                   NBELEM=MAX(NEL1,NEL3)
  331.                ENDIF
  332. *
  333.                N1PTEL=0
  334.                N1EL  =0
  335.                N2PTEL=NBPGAU
  336.                N2EL  =NBELEM
  337. *
  338.                IML=1
  339.             ELSE
  340. *
  341. *              COMPOSANTE NON RECONNUE
  342. *
  343.                MOTERR (1:4)=MCHAM1.NOMCHE(ICOMP)
  344.                CALL ERREUR (197)
  345.                SEGSUP MCHAML,MCHELM,MTRAA
  346.                GOTO 666
  347.             ENDIF
  348.             SEGINI MELVAL
  349.             IELVAL(ICOMP)=MELVAL
  350. *
  351. *           MOT-CLE "SUPE" OU "INFE"
  352.             IF (ICLE.EQ.1) THEN
  353.                DO 331 IGAU=1,NBPGAU
  354.                   IGMN1=MIN(IGAU,NBPTE1)
  355.                   IGMN2=MIN(IGAU,NBPTE2)
  356.                   DO 331 IB=1,NBELEM
  357.                      IBMN1=MIN(IB,NEL1)
  358.                      IBMN2=MIN(IB,NEL2)
  359.                      IF (IML.EQ.0) THEN
  360.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  361.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  362.                         IF (XTT1.GT.XTT2) THEN
  363.                            VELCHE(IGAU,IB)=1.D0
  364.                            KSOM=KSOM+1
  365.                         ENDIF
  366.                      ELSE
  367.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  368.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  369.                         IPRO1=MLREE1.PROG(/1)
  370.                         IPRO2=MLREE2.PROG(/1)
  371.                         JG=MAX(IPRO1,IPRO2)
  372. *
  373.                         SEGINI MLREEL
  374. *
  375.                         DO 302 IPROG=1,JG
  376.                            IPMN1=MIN(IPRO1,IPROG)
  377.                            IPMN2=MIN(IPRO2,IPROG)
  378.                            XTT1=MLREE1.PROG(IPMN1)
  379.                            XTT2=MLREE2.PROG(IPMN2)
  380.                            IF (XTT1.GT.XTT2) THEN
  381.                               PROG(IPROG)=1.D0
  382.                               KSOM=KSOM+1
  383.                            ENDIF
  384.  302                    CONTINUE
  385.                         IELCHE(IGAU,IB)=MLREEL
  386.                      ENDIF
  387.   331          CONTINUE
  388. *
  389. *           MOT-CLE "EGSU" OU "EGIN"
  390.             ELSEIF (ICLE.EQ.2) THEN
  391.                DO 332 IGAU=1,NBPGAU
  392.                   IGMN1=MIN(IGAU,NBPTE1)
  393.                   IGMN2=MIN(IGAU,NBPTE2)
  394.                   DO 332 IB=1,NBELEM
  395.                      IBMN1=MIN(IB,NEL1)
  396.                      IBMN2=MIN(IB,NEL2)
  397.                      IF (IML.EQ.0) THEN
  398.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  399.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  400.                         IF (XTT1.GE.XTT2) THEN
  401.                            VELCHE(IGAU,IB)=1.D0
  402.                            KSOM=KSOM+1
  403.                         ENDIF
  404.                      ELSE
  405.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  406.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  407.                         IPRO1=MLREE1.PROG(/1)
  408.                         IPRO2=MLREE2.PROG(/1)
  409.                         JG=MAX(IPRO1,IPRO2)
  410. *
  411.                         SEGINI MLREEL
  412. *
  413.                         DO 303 IPROG=1,JG
  414.                            IPMN1=MIN(IPRO1,IPROG)
  415.                            IPMN2=MIN(IPRO2,IPROG)
  416.                            XTT1=MLREE1.PROG(IPMN1)
  417.                            XTT2=MLREE2.PROG(IPMN2)
  418.                            IF (XTT1.GE.XTT2) THEN
  419.                               PROG(IPROG)=1.D0
  420.                               KSOM=KSOM+1
  421.                            ENDIF
  422.  303                    CONTINUE
  423.                         IELCHE(IGAU,IB)=MLREEL
  424.                      ENDIF
  425.   332          CONTINUE
  426. *
  427. *           MOT-CLE "EGAL"
  428.             ELSEIF (ICLE.EQ.3) THEN
  429.                DO 333 IGAU=1,NBPGAU
  430.                   IGMN1=MIN(IGAU,NBPTE1)
  431.                   IGMN2=MIN(IGAU,NBPTE2)
  432.                   DO 333 IB=1,NBELEM
  433.                      IBMN1=MIN(IB,NEL1)
  434.                      IBMN2=MIN(IB,NEL2)
  435.                      IF (IML.EQ.0) THEN
  436.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  437.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  438.                         IF (XTT1.EQ.XTT2) THEN
  439.                            VELCHE(IGAU,IB)=1.D0
  440.                            KSOM=KSOM+1
  441.                         ENDIF
  442.                      ELSE
  443.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  444.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  445.                         IPRO1=MLREE1.PROG(/1)
  446.                         IPRO2=MLREE2.PROG(/1)
  447.                         JG=MAX(IPRO1,IPRO2)
  448. *
  449.                         SEGINI MLREEL
  450. *
  451.                         DO 304 IPROG=1,JG
  452.                            IPMN1=MIN(IPRO1,IPROG)
  453.                            IPMN2=MIN(IPRO2,IPROG)
  454.                            XTT1=MLREE1.PROG(IPMN1)
  455.                            XTT2=MLREE2.PROG(IPMN2)
  456.                            IF (XTT1.EQ.XTT2) THEN
  457.                               PROG(IPROG)=1.D0
  458.                               KSOM=KSOM+1
  459.                            ENDIF
  460.  304                    CONTINUE
  461.                         IELCHE(IGAU,IB)=MLREEL
  462.                      ENDIF
  463.   333          CONTINUE
  464. *
  465. *           MOT-CLE "DIFF"
  466.             ELSEIF (ICLE.EQ.6) THEN
  467.                DO 336 IGAU=1,NBPGAU
  468.                   IGMN1=MIN(IGAU,NBPTE1)
  469.                   IGMN2=MIN(IGAU,NBPTE2)
  470.                   DO 336 IB=1,NBELEM
  471.                      IBMN1=MIN(IB,NEL1)
  472.                      IBMN2=MIN(IB,NEL2)
  473.                      IF (IML.EQ.0) THEN
  474.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  475.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  476.                         IF (XTT1.NE.XTT2) THEN
  477.                            VELCHE(IGAU,IB)=1.D0
  478.                            KSOM=KSOM+1
  479.                         ENDIF
  480.                      ELSE
  481.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  482.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  483.                         IPRO1=MLREE1.PROG(/1)
  484.                         IPRO2=MLREE2.PROG(/1)
  485.                         JG=MAX(IPRO1,IPRO2)
  486. *
  487.                         SEGINI MLREEL
  488. *
  489.                         DO 305 IPROG=1,JG
  490.                            IPMN1=MIN(IPRO1,IPROG)
  491.                            IPMN2=MIN(IPRO2,IPROG)
  492.                            XTT1=MLREE1.PROG(IPMN1)
  493.                            XTT2=MLREE2.PROG(IPMN2)
  494.                            IF (XTT1.NE.XTT2) THEN
  495.                               PROG(IPROG)=1.D0
  496.                               KSOM=KSOM+1
  497.                            ENDIF
  498.  305                    CONTINUE
  499.                         IELCHE(IGAU,IB)=MLREEL
  500.                      ENDIF
  501.   336          CONTINUE
  502. *
  503. *           MOT-CLE "COMP"
  504.             ELSEIF (ICLE.EQ.7) THEN
  505.                IF (IKOK.EQ.0) THEN
  506.                   DO 337 IGAU=1,NBPGAU
  507.                      IGMN1=MIN(IGAU,NBPTE1)
  508.                      IGMN2=MIN(IGAU,NBPTE2)
  509.                      IGMN3=MIN(IGAU,NBPTE3)
  510.                      DO 337 IB=1,NBELEM
  511.                         IBMN1=MIN(IB,NEL1)
  512.                         IBMN2=MIN(IB,NEL2)
  513.                         IBMN3=MIN(IB,NEL3)
  514.                         IF (IML.EQ.0) THEN
  515.                            XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  516.                            XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  517.                            XTT3 =MELVA3.VELCHE(IGMN3,IBMN3)
  518.                            IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  519.                               VELCHE(IGAU,IB)=1.D0
  520.                               KSOM=KSOM+1
  521.                            ENDIF
  522.                         ELSE
  523.                            MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  524.                            MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  525.                            MLREE3=MELVA3.IELCHE(IGMN3,IBMN3)
  526.                            IPRO1=MLREE1.PROG(/1)
  527.                            IPRO2=MLREE2.PROG(/1)
  528.                            IPRO3=MLREE3.PROG(/1)
  529.                            JG=MAX(IPRO1,IPRO2,IPRO3)
  530. *
  531.                            SEGINI MLREEL
  532. *
  533.                            DO 306 IPROG=1,JG
  534.                               IPMN1=MIN(IPRO1,IPROG)
  535.                               IPMN2=MIN(IPRO2,IPROG)
  536.                               IPMN3=MIN(IPRO3,IPROG)
  537.                               XTT1=MLREE1.PROG(IPMN1)
  538.                               XTT2=MLREE2.PROG(IPMN2)
  539.                               XTT3=MLREE3.PROG(IPMN3)
  540.                               IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  541.                                  PROG(IPROG)=1.D0
  542.                                  KSOM=KSOM+1
  543.                               ENDIF
  544.  306                       CONTINUE
  545.                            IELCHE(IGAU,IB)=MLREEL
  546.                         ENDIF
  547.   337             CONTINUE
  548.                ELSEIF (IKOK.GT.0) THEN
  549.                   DO 338 IGAU=1,NBPGAU
  550.                      IGMN1=MIN(IGAU,NBPTE1)
  551.                      IGMN2=MIN(IGAU,NBPTE2)
  552.                      DO 338 IB=1,NBELEM
  553.                         IBMN1=MIN(IB,NEL1)
  554.                         IBMN2=MIN(IB,NEL2)
  555.                         IF (IML.EQ.0) THEN
  556.                            XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  557.                            XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  558.                            IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  559.                               VELCHE(IGAU,IB)=1.D0
  560.                               KSOM=KSOM+1
  561.                            ENDIF
  562.                         ELSE
  563.                            MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  564.                            MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  565.                            IPRO1=MLREE1.PROG(/1)
  566.                            IPRO2=MLREE2.PROG(/1)
  567.                            JG=MAX(IPRO1,IPRO2)
  568. *
  569.                            SEGINI MLREEL
  570. *
  571.                            DO 307 IPROG=1,JG
  572.                               IPMN1=MIN(IPRO1,IPROG)
  573.                               IPMN2=MIN(IPRO2,IPROG)
  574.                               XTT1=MLREE1.PROG(IPMN1)
  575.                               XTT2=MLREE2.PROG(IPMN2)
  576.                               IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  577.                                  PROG(IPROG)=1.D0
  578.                                  KSOM=KSOM+1
  579.                               ENDIF
  580.  307                       CONTINUE
  581.                            IELCHE(IGAU,IB)=MLREEL
  582.                         ENDIF
  583.   338             CONTINUE
  584.                ELSE
  585.                   DO 339 IGAU=1,NBPGAU
  586.                      IGMN1=MIN(IGAU,NBPTE1)
  587.                      IGMN2=MIN(IGAU,NBPTE2)
  588.                      DO 339 IB=1,NBELEM
  589.                         IBMN1=MIN(IB,NEL1)
  590.                         IBMN2=MIN(IB,NEL2)
  591.                         IF (IML.EQ.0) THEN
  592.                            XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  593.                            XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  594.                            IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  595.                               VELCHE(IGAU,IB)=1.D0
  596.                               KSOM=KSOM+1
  597.                            ENDIF
  598.                         ELSE
  599.                            MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  600.                            MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  601.                            IPRO1=MLREE1.PROG(/1)
  602.                            IPRO2=MLREE2.PROG(/1)
  603.                            JG=MAX(IPRO1,IPRO2)
  604. *
  605.                            SEGINI MLREEL
  606. *
  607.                            DO 308 IPROG=1,JG
  608.                               IPMN1=MIN(IPRO1,IPROG)
  609.                               IPMN2=MIN(IPRO2,IPROG)
  610.                               XTT1=MLREE1.PROG(IPMN1)
  611.                               XTT2=MLREE2.PROG(IPMN2)
  612.                               IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  613.                                  PROG(IPROG)=1.D0
  614.                                  KSOM=KSOM+1
  615.                               ENDIF
  616.  308                       CONTINUE
  617.                            IELCHE(IGAU,IB)=MLREEL
  618.                         ENDIF
  619.   339             CONTINUE
  620.                ENDIF
  621.  
  622.             ENDIF
  623. * cas des champs constants par element ou maillage elementaire
  624.              if(nbpgau.lt.nnptel) ksom = ksom * nnptel
  625.              if(nbelem.lt.nnel) ksom = ksom * nnel
  626.  300     CONTINUE
  627.  200  CONTINUE
  628. *
  629. *     FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  630. *     DESACTIVATON DES SEGMENTS
  631. *
  632.       SEGSUP MTRAA
  633.       IF (IKOK.EQ.0) SEGSUP MTRAA2
  634.       IF (ISOM.EQ.1) THEN
  635.          CALL DTCHAM(IPCHMA)
  636.          IPCHMA=KSOM
  637.       ENDIF
  638.       IRET = 1
  639.  
  640.  666  CONTINUE
  641. C      RETURN
  642.       END
  643.  
  644.  
  645.  

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