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    CB215821  26/08/24    21:17:22     12622          
  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 667 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.   667          CONTINUE
  389. *
  390. *           MOT-CLE "EGSU" OU "EGIN"
  391.             ELSEIF (ICLE.EQ.2) THEN
  392.                DO 668 IGAU=1,NBPGAU
  393.                   IGMN1=MIN(IGAU,NBPTE1)
  394.                   IGMN2=MIN(IGAU,NBPTE2)
  395.                   DO 332 IB=1,NBELEM
  396.                      IBMN1=MIN(IB,NEL1)
  397.                      IBMN2=MIN(IB,NEL2)
  398.                      IF (IML.EQ.0) THEN
  399.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  400.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  401.                         IF (XTT1.GE.XTT2) THEN
  402.                            VELCHE(IGAU,IB)=1.D0
  403.                            KSOM=KSOM+1
  404.                         ENDIF
  405.                      ELSE
  406.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  407.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  408.                         IPRO1=MLREE1.PROG(/1)
  409.                         IPRO2=MLREE2.PROG(/1)
  410.                         JG=MAX(IPRO1,IPRO2)
  411. *
  412.                         SEGINI MLREEL
  413. *
  414.                         DO 303 IPROG=1,JG
  415.                            IPMN1=MIN(IPRO1,IPROG)
  416.                            IPMN2=MIN(IPRO2,IPROG)
  417.                            XTT1=MLREE1.PROG(IPMN1)
  418.                            XTT2=MLREE2.PROG(IPMN2)
  419.                            IF (XTT1.GE.XTT2) THEN
  420.                               PROG(IPROG)=1.D0
  421.                               KSOM=KSOM+1
  422.                            ENDIF
  423.  303                    CONTINUE
  424.                         IELCHE(IGAU,IB)=MLREEL
  425.                      ENDIF
  426.   332          CONTINUE
  427.   668          CONTINUE
  428. *
  429. *           MOT-CLE "EGAL"
  430.             ELSEIF (ICLE.EQ.3) THEN
  431.                DO 669 IGAU=1,NBPGAU
  432.                   IGMN1=MIN(IGAU,NBPTE1)
  433.                   IGMN2=MIN(IGAU,NBPTE2)
  434.                   DO 333 IB=1,NBELEM
  435.                      IBMN1=MIN(IB,NEL1)
  436.                      IBMN2=MIN(IB,NEL2)
  437.                      IF (IML.EQ.0) THEN
  438.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  439.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  440.                         IF (XTT1.EQ.XTT2) THEN
  441.                            VELCHE(IGAU,IB)=1.D0
  442.                            KSOM=KSOM+1
  443.                         ENDIF
  444.                      ELSE
  445.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  446.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  447.                         IPRO1=MLREE1.PROG(/1)
  448.                         IPRO2=MLREE2.PROG(/1)
  449.                         JG=MAX(IPRO1,IPRO2)
  450. *
  451.                         SEGINI MLREEL
  452. *
  453.                         DO 304 IPROG=1,JG
  454.                            IPMN1=MIN(IPRO1,IPROG)
  455.                            IPMN2=MIN(IPRO2,IPROG)
  456.                            XTT1=MLREE1.PROG(IPMN1)
  457.                            XTT2=MLREE2.PROG(IPMN2)
  458.                            IF (XTT1.EQ.XTT2) THEN
  459.                               PROG(IPROG)=1.D0
  460.                               KSOM=KSOM+1
  461.                            ENDIF
  462.  304                    CONTINUE
  463.                         IELCHE(IGAU,IB)=MLREEL
  464.                      ENDIF
  465.   333          CONTINUE
  466.   669          CONTINUE
  467. *
  468. *           MOT-CLE "DIFF"
  469.             ELSEIF (ICLE.EQ.6) THEN
  470.                DO 670 IGAU=1,NBPGAU
  471.                   IGMN1=MIN(IGAU,NBPTE1)
  472.                   IGMN2=MIN(IGAU,NBPTE2)
  473.                   DO 336 IB=1,NBELEM
  474.                      IBMN1=MIN(IB,NEL1)
  475.                      IBMN2=MIN(IB,NEL2)
  476.                      IF (IML.EQ.0) THEN
  477.                         XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  478.                         XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  479.                         IF (XTT1.NE.XTT2) THEN
  480.                            VELCHE(IGAU,IB)=1.D0
  481.                            KSOM=KSOM+1
  482.                         ENDIF
  483.                      ELSE
  484.                         MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  485.                         MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  486.                         IPRO1=MLREE1.PROG(/1)
  487.                         IPRO2=MLREE2.PROG(/1)
  488.                         JG=MAX(IPRO1,IPRO2)
  489. *
  490.                         SEGINI MLREEL
  491. *
  492.                         DO 305 IPROG=1,JG
  493.                            IPMN1=MIN(IPRO1,IPROG)
  494.                            IPMN2=MIN(IPRO2,IPROG)
  495.                            XTT1=MLREE1.PROG(IPMN1)
  496.                            XTT2=MLREE2.PROG(IPMN2)
  497.                            IF (XTT1.NE.XTT2) THEN
  498.                               PROG(IPROG)=1.D0
  499.                               KSOM=KSOM+1
  500.                            ENDIF
  501.  305                    CONTINUE
  502.                         IELCHE(IGAU,IB)=MLREEL
  503.                      ENDIF
  504.   336          CONTINUE
  505.   670          CONTINUE
  506. *
  507. *           MOT-CLE "COMP"
  508.             ELSEIF (ICLE.EQ.7) THEN
  509.                IF (IKOK.EQ.0) THEN
  510.                   DO 671 IGAU=1,NBPGAU
  511.                      IGMN1=MIN(IGAU,NBPTE1)
  512.                      IGMN2=MIN(IGAU,NBPTE2)
  513.                      IGMN3=MIN(IGAU,NBPTE3)
  514.                      DO 337 IB=1,NBELEM
  515.                         IBMN1=MIN(IB,NEL1)
  516.                         IBMN2=MIN(IB,NEL2)
  517.                         IBMN3=MIN(IB,NEL3)
  518.                         IF (IML.EQ.0) THEN
  519.                            XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  520.                            XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  521.                            XTT3 =MELVA3.VELCHE(IGMN3,IBMN3)
  522.                            IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  523.                               VELCHE(IGAU,IB)=1.D0
  524.                               KSOM=KSOM+1
  525.                            ENDIF
  526.                         ELSE
  527.                            MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  528.                            MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  529.                            MLREE3=MELVA3.IELCHE(IGMN3,IBMN3)
  530.                            IPRO1=MLREE1.PROG(/1)
  531.                            IPRO2=MLREE2.PROG(/1)
  532.                            IPRO3=MLREE3.PROG(/1)
  533.                            JG=MAX(IPRO1,IPRO2,IPRO3)
  534. *
  535.                            SEGINI MLREEL
  536. *
  537.                            DO 306 IPROG=1,JG
  538.                               IPMN1=MIN(IPRO1,IPROG)
  539.                               IPMN2=MIN(IPRO2,IPROG)
  540.                               IPMN3=MIN(IPRO3,IPROG)
  541.                               XTT1=MLREE1.PROG(IPMN1)
  542.                               XTT2=MLREE2.PROG(IPMN2)
  543.                               XTT3=MLREE3.PROG(IPMN3)
  544.                               IF (XTT1.GE.XTT2.AND.XTT1.LE.XTT3) THEN
  545.                                  PROG(IPROG)=1.D0
  546.                                  KSOM=KSOM+1
  547.                               ENDIF
  548.  306                       CONTINUE
  549.                            IELCHE(IGAU,IB)=MLREEL
  550.                         ENDIF
  551.   337             CONTINUE
  552.   671             CONTINUE
  553.                ELSEIF (IKOK.GT.0) THEN
  554.                   DO 672 IGAU=1,NBPGAU
  555.                      IGMN1=MIN(IGAU,NBPTE1)
  556.                      IGMN2=MIN(IGAU,NBPTE2)
  557.                      DO 338 IB=1,NBELEM
  558.                         IBMN1=MIN(IB,NEL1)
  559.                         IBMN2=MIN(IB,NEL2)
  560.                         IF (IML.EQ.0) THEN
  561.                            XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  562.                            XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  563.                            IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  564.                               VELCHE(IGAU,IB)=1.D0
  565.                               KSOM=KSOM+1
  566.                            ENDIF
  567.                         ELSE
  568.                            MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  569.                            MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  570.                            IPRO1=MLREE1.PROG(/1)
  571.                            IPRO2=MLREE2.PROG(/1)
  572.                            JG=MAX(IPRO1,IPRO2)
  573. *
  574.                            SEGINI MLREEL
  575. *
  576.                            DO 307 IPROG=1,JG
  577.                               IPMN1=MIN(IPRO1,IPROG)
  578.                               IPMN2=MIN(IPRO2,IPROG)
  579.                               XTT1=MLREE1.PROG(IPMN1)
  580.                               XTT2=MLREE2.PROG(IPMN2)
  581.                               IF (XTT1.GE.X1.AND.XTT1.LE.XTT2) THEN
  582.                                  PROG(IPROG)=1.D0
  583.                                  KSOM=KSOM+1
  584.                               ENDIF
  585.  307                       CONTINUE
  586.                            IELCHE(IGAU,IB)=MLREEL
  587.                         ENDIF
  588.   338             CONTINUE
  589.   672             CONTINUE
  590.                ELSE
  591.                   DO 673 IGAU=1,NBPGAU
  592.                      IGMN1=MIN(IGAU,NBPTE1)
  593.                      IGMN2=MIN(IGAU,NBPTE2)
  594.                      DO 339 IB=1,NBELEM
  595.                         IBMN1=MIN(IB,NEL1)
  596.                         IBMN2=MIN(IB,NEL2)
  597.                         IF (IML.EQ.0) THEN
  598.                            XTT1 =MELVA1.VELCHE(IGMN1,IBMN1)
  599.                            XTT2 =MELVA2.VELCHE(IGMN2,IBMN2)
  600.                            IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  601.                               VELCHE(IGAU,IB)=1.D0
  602.                               KSOM=KSOM+1
  603.                            ENDIF
  604.                         ELSE
  605.                            MLREE1=MELVA1.IELCHE(IGMN1,IBMN1)
  606.                            MLREE2=MELVA2.IELCHE(IGMN2,IBMN2)
  607.                            IPRO1=MLREE1.PROG(/1)
  608.                            IPRO2=MLREE2.PROG(/1)
  609.                            JG=MAX(IPRO1,IPRO2)
  610. *
  611.                            SEGINI MLREEL
  612. *
  613.                            DO 308 IPROG=1,JG
  614.                               IPMN1=MIN(IPRO1,IPROG)
  615.                               IPMN2=MIN(IPRO2,IPROG)
  616.                               XTT1=MLREE1.PROG(IPMN1)
  617.                               XTT2=MLREE2.PROG(IPMN2)
  618.                               IF (XTT1.GE.XTT2.AND.XTT1.LE.X1) THEN
  619.                                  PROG(IPROG)=1.D0
  620.                                  KSOM=KSOM+1
  621.                               ENDIF
  622.  308                       CONTINUE
  623.                            IELCHE(IGAU,IB)=MLREEL
  624.                         ENDIF
  625.   339             CONTINUE
  626.   673             CONTINUE
  627.                ENDIF
  628.  
  629.             ENDIF
  630. * cas des champs constants par element ou maillage elementaire
  631.              if(nbpgau.lt.nnptel) ksom = ksom * nnptel
  632.              if(nbelem.lt.nnel) ksom = ksom * nnel
  633.  300     CONTINUE
  634.  200  CONTINUE
  635. *
  636. *     FIN DE LA BOUCLE SUR LES SOUS PAQUETS DE MCHEL1
  637. *     DESACTIVATON DES SEGMENTS
  638. *
  639.       SEGSUP MTRAA
  640.       IF (IKOK.EQ.0) SEGSUP MTRAA2
  641.       IF (ISOM.EQ.1) THEN
  642.          CALL DTCHAM(IPCHMA)
  643.          IPCHMA=KSOM
  644.       ENDIF
  645.       IRET = 1
  646.  
  647.  666  CONTINUE
  648. C      RETURN
  649.       END
  650.  
  651.  
  652.  
  653.  

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