C EXPCHP SOURCE CHAT 05/01/12 23:51:20 5004 SUBROUTINE EXPCHP(IPCHPO,IMM,IAB,IAV,IPLIS,VALREF,VALRE2,IPMAIL) * * EXTRAIRE LE OU LES POINTS SUPPORTS DU MAXI OU DU MINI DES VALEURS DE * COMPOSANTES D'UN CHAMP/POINT * ************************************************************************ * ENTREES : * * IPCHPO =POINTEUR SUR UN CHPOINT * IMM = 1 MAXI , 2 MINI , 3 A 8 AUTRES * IAB = 0 VALEURS ALGEBRIQUES ,1 VALEURS ABSOLUES * IAV = 1 LES NOMS DE LA LISEMOTS SONT CONSIDERES ,2 ILS SONT EXC * IPLIS = POINTEUR SUR UN LISTMOTS * VALREF = VALEUR DE REFERENCE * VALRE2 = IDEM POUR OPTION COMPRIS * * SORTIES : * * IPMAIL = POINTEUR SUR OBJET MAILLAGE CONTENANT LE OU LES POINTS * SUPPORTS DU MAXI OU DU MINI OU AUTRES * * P DOWLATYARI OCT 91 ************************************************************************ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) * -INC CCOPTIO -INC SMCHPOI -INC SMELEME -INC SMCOORD -INC SMLMOTS * SEGMENT QUELCO INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS) ENDSEGMENT * SEGMENT ICPR(xcoor(/1)/(IDIM+1)) CHARACTER*4 MOCOMP DIMENSION XE(3,1) * * 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 * * ON RECUPERE LE CHPOINT * MCHPOI=IPCHPO SEGACT MCHPOI NSOUS = IPCHP(/1) * * ON CHERCHE LE NOMBRE MAXIMAL DE COMPOSANTES * NCOMX = 0 DO 10 ISOUS=1,NSOUS MSOUPO=IPCHP(ISOUS) SEGACT MSOUPO NCOMX=MAX(NCOMX,NOCOMP(/2)) 10 CONTINUE * IF(IPLIS.NE.0)SEGINI QUELCO * * BOUCLE SUR LES SOUS-ZONES POUR TROUVER LE MAXI OU LE MINI * SI IMM = 1 OU 2 * DO 500 ISOUS=1,NSOUS * MSOUPO=IPCHP(ISOUS) NCOMP=NOCOMP(/2) IF(IPLIS.NE.0)THEN NCO=0 DO 20 ICOMP=1,NCOMP MOCOMP=NOCOMP(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 * IF(IMM.LE.2) THEN * IF(IPLIS.EQ.0)THEN MPOVAL=IPOVAL SEGACT MPOVAL N=VPOCHA(/1) DO 100 ICOMP=1,NCOMP DO 100 IB=1,N XX=VPOCHA(IB,ICOMP) IF(IAB.EQ.1) XX=ABS(XX) IF(IMM.EQ.1)THEN XEXT=MAX(XX,XEXT) ELSE XEXT=MIN(XX,XEXT) ENDIF 100 CONTINUE SEGDES MPOVAL ELSEIF(NCO.NE.0)THEN MPOVAL=IPOVAL SEGACT MPOVAL N=VPOCHA(/1) DO 110 ICOMP=1,NCOMP IF(ICO(ISOUS,ICOMP).EQ.1)THEN DO 210 IB=1,N XX=VPOCHA(IB,ICOMP) IF(IAB.EQ.1) XX=ABS(XX) IF(IMM.EQ.1)THEN XEXT=MAX(XX,XEXT) ELSE XEXT=MIN(XX,XEXT) ENDIF 210 CONTINUE ENDIF 110 CONTINUE SEGDES MPOVAL ENDIF ENDIF * SEGDES MSOUPO 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 MCHPOI SEGSUP QUELCO IPMAIL=0 RETURN ENDIF ENDIF * * CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS * NBNN=1 NBELEM=XCOOR(/1)/(IDIM+1) NBSOUS=0 NBREF=0 SEGINI MELEME IPMAIL=MELEME ITYPEL=1 NBELEM=0 * * DEUXIEME BOUCLE SUR LES SOUS-ZONES POUR TROUVER LES POINTS SUPPORTS * DO 600 ISOUS=1,NSOUS * MSOUPO=IPCHP(ISOUS) SEGACT MSOUPO NCOMP=NOCOMP(/2) IPT1=IGEOC SEGACT IPT1 IF(IPLIS.EQ.0)THEN MPOVAL=IPOVAL SEGACT MPOVAL N=VPOCHA(/1) DO 300 ICOMP=1,NCOMP DO 300 IB=1,N XX=VPOCHA(IB,ICOMP) 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 MCHPOI SEGSUP QUELCO IPMAIL=0 RETURN * * MAXI OU MINI 21 IF(XX.EQ.XEXT) GO TO 303 GO TO 300 * * SUPE 23 IF(XX.GT.VALREF) GO TO 303 GO TO 300 * * EGSUPE 24 IF(XX.GE.VALREF) GO TO 303 GO TO 300 * * EGAL 25 IF(XX.EQ.VALREF) GO TO 303 GO TO 300 * * EGINFE 26 IF(XX.LE.VALREF) GO TO 303 GO TO 300 * * INFE 27 IF(XX.LT.VALREF) GO TO 303 GO TO 300 * * DIFF 28 IF(XX.NE.VALREF) GO TO 303 GO TO 300 * * COMP 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 303 GO TO 300 * 303 CONTINUE NBELEM=NBELEM+1 * SEGADJ MELEME NUM(1,NBELEM)=IPT1.NUM(1,IB) * 300 CONTINUE SEGDES MPOVAL * ELSEIF(NNCO(ISOUS).NE.0)THEN MPOVAL=IPOVAL SEGACT MPOVAL N=VPOCHA(/1) DO 310 ICOMP=1,NCOMP IF(ICO(ISOUS,ICOMP).EQ.1)THEN DO 410 IB=1,N XX=VPOCHA(IB,ICOMP) 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 MCHPOI SEGSUP QUELCO IPMAIL=0 RETURN * * MAXI OU MINI 31 IF(XX.EQ.XEXT) GO TO 413 GO TO 410 * * SUPE 33 IF(XX.GT.VALREF) GO TO 413 GO TO 410 * * EGSUPE 34 IF(XX.GE.VALREF) GO TO 413 GO TO 410 * * EGAL 35 IF(XX.EQ.VALREF) GO TO 413 GO TO 410 * * EGINFE 36 IF(XX.LE.VALREF) GO TO 413 GO TO 410 * * INFE 37 IF(XX.LT.VALREF) GO TO 413 GO TO 410 * * DIFF 38 IF(XX.NE.VALREF) GO TO 413 GO TO 410 * * COMP 39 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2)) GO TO 413 GO TO 410 * 413 CONTINUE NBELEM=NBELEM+1 * SEGADJ MELEME NUM(1,NBELEM)=IPT1.NUM(1,IB) 410 CONTINUE * ENDIF 310 CONTINUE SEGDES MPOVAL ENDIF SEGDES MSOUPO,IPT1 * 600 CONTINUE SEGADJ MELEME SEGDES MCHPOI,MELEME IF(IPLIS.NE.0)SEGSUP QUELCO RETURN END