C EXELCH SOURCE PV 09/03/12 21:21:56 6325 SUBROUTINE EXELCH(IPCHEL,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL) * * EXTRAIRE LE OU LES ELEMENTS SUPPORTS DU MAXI OU DU MINI DES VALEURS * COMPOSANTES D'UN CHAMP/ELEMENT * ************************************************************************ * ENTREES : * * IPCHEL =POINTEUR SUR UN MCHAML * IMM = 1 MAXI , 2 MINI , 3 A 8 LES AUTRES * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES * IAV = 1 LES NOMS DE LA LISTMOTS SONT CONSIDERES ,2 ILS SONT EXC * IPLIS = POINTEUR SUR UN LISTMOTS * VALREF = VALEUR POUR FAIRE LES COMPARAISONS * VALRE2 = IDEM POUR OPTION 'COMPRIS' * * SORTIES : * * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES ELEMENTS * SUPPORTS DU MAXI OU DU MINI OU SATISFAISANT LES TESTS * PAR RAPPORT A VALREF * * P DOWLATYARI OCT 91 ************************************************************************ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC CCOPTIO -INC SMCHAML -INC SMELEME -INC SMCOORD -INC SMLMOTS * logical ltelq SEGMENT QUELCO INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS) ENDSEGMENT SEGMENT QQQQ INTEGER ICC(NBEL1) ENDSEGMENT * SEGMENT MESH INTEGER IMA(NSOUS),IMB(NSOUS) ENDSEGMENT * CHARACTER*4 MOCOMP * * INITIALISATIONS * IF(IAB.EQ.0)THEN IF(IMM.EQ.1)THEN XEXT=-1.D35 ELSE XEXT=1.D35 ENDIF ELSE IF(IMM.EQ.1)THEN XEXT=0.D0 ELSE XEXT=1.D35 ENDIF ENDIF * IF(IPLIS.NE.0)THEN MLMOTS=IPLIS SEGACT MLMOTS NC=MOTS(/2) ENDIF C C ON RECUPERE LE CHAMELEM C MCHELM=IPCHEL SEGACT MCHELM NSOUS=IMACHE(/1) * * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES * NCOMX = 0 DO 10 ISOUS=1,NSOUS MCHAML=ICHAML(ISOUS) SEGACT MCHAML NCOMX=MAX(NCOMX,NOMCHE(/2)) 10 CONTINUE * IF(IPLIS.NE.0)SEGINI QUELCO * * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI * DO 500 ISOUS=1,NSOUS * MCHAML=ICHAML(ISOUS) NCOMP=NOMCHE(/2) IF(IPLIS.NE.0)THEN NCO=0 DO 20 ICOMP=1,NCOMP MOCOMP=NOMCHE(ICOMP) CALL PLACE(MOTS,NC,IX,MOCOMP) IF(IAV.EQ.1)THEN IF(IX.NE.0)THEN ICO(ISOUS,ICOMP)=1 NCO=NCO+1 ELSE ICO(ISOUS,ICOMP)=0 ENDIF ELSE IF(IX.EQ.0)THEN ICO(ISOUS,ICOMP)=1 NCO=NCO+1 ELSE ICO(ISOUS,ICOMP)=0 ENDIF ENDIF 20 CONTINUE NNCO(ISOUS)=NCO ENDIF * * RECHERCHE DU MAXI OU MINI ( IMM = 1 OU 2 ) * IF(IMM.LE.2) THEN * IF(IPLIS.EQ.0)THEN DO 100 ICOMP=1,NCOMP MELVAL=IELVAL(ICOMP) SEGACT MELVAL NEL=VELCHE(/2) NBPTEL=VELCHE(/1) DO 200 IB=1,NEL DO 200 IGAU=1,NBPTEL XX=VELCHE(IGAU,IB) IF(IAB.EQ.1)XX=ABS(XX) IF(IMM.EQ.1) THEN XEXT=MAX(XX,XEXT) ELSE XEXT=MIN(XX,XEXT) ENDIF 200 CONTINUE SEGDES MELVAL 100 CONTINUE ELSEIF(NCO.NE.0)THEN DO 110 ICOMP=1,NCOMP IF(ICO(ISOUS,ICOMP).EQ.1)THEN MELVAL=IELVAL(ICOMP) SEGACT MELVAL NEL=VELCHE(/2) NBPTEL=VELCHE(/1) DO 210 IB=1,NEL DO 210 IGAU=1,NBPTEL XX=VELCHE(IGAU,IB) IF(IAB.EQ.1)XX=ABS(XX) IF(IMM.EQ.1) THEN XEXT=MAX(XX,XEXT) ELSE XEXT=MIN(XX,XEXT) ENDIF 210 CONTINUE SEGDES MELVAL ENDIF 110 CONTINUE ENDIF * ENDIF SEGDES MCHAML 500 CONTINUE * IF(IPLIS.NE.0)THEN SEGDES MLMOTS NZERO=0 DO 510 ISOUS=1,NSOUS IF(NNCO(ISOUS).EQ.0)NZERO=NZERO+1 510 CONTINUE IF(NZERO.EQ.NSOUS)THEN CALL ERREUR(280) SEGDES MCHELM SEGSUP QUELCO IPMAIL=0 RETURN ENDIF ENDIF * * * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS * SEGINI MESH DO 600 ISOUS=1,NSOUS * MCHAML=ICHAML(ISOUS) SEGACT MCHAML NCOMP=NOMCHE(/2) IPT1=IMACHE(ISOUS) SEGACT IPT1 NBNN1=IPT1.NUM(/1) NBEL1=IPT1.NUM(/2) NBNN=NBNN1 NBELEM=0 NBSOUS=0 NBREF=0 segini QQQQ SEGINI MELEME ITYPEL=IPT1.ITYPEL IF(IPLIS.EQ.0)THEN DO 300 ICOMP=1,NCOMP MELVAL=IELVAL(ICOMP) SEGACT MELVAL NBPTEL=VELCHE(/1) NEL=VELCHE(/2) DO 400 IB=1,NBEL1 IBMN=MIN(IB,NEL) DO 401 IGAU=1,NBPTEL XX=VELCHE(IGAU,IBMN) IF(IAB.EQ.1)XX=ABS(XX) * * TRI SELON LA VALEUR DE IMM * GO TO (21,21,23,24,25,26,27,28,29),IMM * CALL ERREUR(280) SEGDES MELVAL SEGDES MCHELM SEGSUP QUELCO IPMAIL=0 RETURN * * MAXI OU MINI 21 IF(XX.EQ.XEXT) GO TO 403 GO TO 401 * * SUPE 23 IF(XX.GT.VALREF) GO TO 403 GO TO 401 * * EGSUPE 24 IF(XX.GE.VALREF) GO TO 403 GO TO 401 * * EGAL 25 IF(XX.EQ.VALREF) GO TO 403 GO TO 401 * * EGINFE 26 IF(XX.LE.VALREF) GO TO 403 GO TO 401 * * INFE 27 IF(XX.LT.VALREF) GO TO 403 GO TO 401 * * DIFF 28 IF(XX.NE.VALREF) GO TO 403 GO TO 401 * * COMP 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 403 GO TO 401 * 401 CONTINUE GO TO 400 * 403 CONTINUE if (ICC(IB).eq.0) then icc(ib) = 1 NBELEM=NBELEM+1 SEGADJ MELEME DO 405 INO=1,NBNN NUM(INO,NBELEM)=IPT1.NUM(INO,IB) 405 CONTINUE ICOLOR(NBELEM)=IPT1.ICOLOR(IB) endif * 400 CONTINUE SEGDES MELVAL 300 CONTINUE * ELSEIF(NNCO(ISOUS).NE.0)THEN DO 310 ICOMP=1,NCOMP IF(ICO(ISOUS,ICOMP).EQ.1)THEN MELVAL=IELVAL(ICOMP) SEGACT MELVAL NBPTEL=VELCHE(/1) NEL=VELCHE(/2) DO 410 IB=1,NBEL1 IBMN=MIN(IB,NEL) DO 411 IGAU=1,NBPTEL XX=VELCHE(IGAU,IBMN) IF(IAB.EQ.1)XX=ABS(XX) * * TRI SELON LA VALEUR DE IMM * GO TO (31,31,33,34,35,36,37,38,39),IMM * CALL ERREUR(280) SEGDES MELVAL SEGDES MCHELM SEGSUP QUELCO IPMAIL=0 RETURN * * MAXI OU MINI 31 IF(XX.EQ.XEXT) GO TO 413 GO TO 411 * * SUPE 33 IF(XX.GT.VALREF) GO TO 413 GO TO 411 * * EGSUPE 34 IF(XX.GE.VALREF) GO TO 413 GO TO 411 * * EGAL 35 IF(XX.EQ.VALREF) GO TO 413 GO TO 411 * * EGINFE 36 IF(XX.LE.VALREF) GO TO 413 GO TO 411 * * INFE 37 IF(XX.LT.VALREF) GO TO 413 GO TO 411 * * DIFF 38 IF(XX.NE.VALREF) GO TO 413 GO TO 411 * * COMP 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 413 GO TO 411 * 411 CONTINUE GO TO 410 * 413 CONTINUE if (ICC(IB).eq.0) then icc(ib) = 1 NBELEM=NBELEM+1 SEGADJ MELEME DO 406 INO=1,NBNN NUM(INO,NBELEM)=IPT1.NUM(INO,IB) 406 CONTINUE ICOLOR(NBELEM)=IPT1.ICOLOR(IB) endif * 410 CONTINUE SEGDES MELVAL ENDIF 310 CONTINUE * ENDIF SEGDES,MCHAML,IPT1 IF(NBELEM.EQ.0)THEN SEGSUP MELEME IMA(ISOUS)=0 ELSE SEGDES MELEME IMA(ISOUS)=MELEME IMB(ISOUS)=MELEME ENDIF segsup QQQQ 600 CONTINUE * NMAIL=0 DO 610 ISOUS=1,NSOUS IF(IMA(ISOUS).NE.0)THEN NMAIL=NMAIL+1 ISOU1=ISOUS ENDIF 610 CONTINUE * IF(NMAIL.EQ.1)THEN IPMAIL=IMA(ISOU1) ELSE NBSOUS=NMAIL NBREF=0 NBNN=0 NBELEM=0 SEGINI MELEME DO ISOUS = 1,NSOUS IF(IMA(ISOUS).NE.0) THEN IPP1 = IMA(ISOUS) ima(isous) = 0 GOTO 618 ENDIF ENDDO * 618 CONTINUE DO 620 ISOUS=2,NSOUS IF(IMA(ISOUS).NE.0) THEN IPP2= IMA(ISOUS) ltelq=.false. CALL FUSE(IPP1,IPP2,MELEME,ltelq) ipt1 = ipp1 segdes ipt1 IPP1 = MELEME ENDIF 620 CONTINUE SEGACT MELEME DO ISOUS = 1,NSOUS IPT1 = IMB(ISOUS) DO IZ = 1,NBSOUS IF(IPT1.EQ.LISOUS(IZ)) GOTO 621 ENDDO SEGSUP IPT1 621 CONTINUE ENDDO SEGDES MELEME IPMAIL=MELEME ENDIF SEGDES MCHELM IF(IPLIS.NE.0)SEGSUP QUELCO SEGSUP MESH RETURN END