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

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