C EXPCHE SOURCE PV 09/03/12 21:22:01 6325 SUBROUTINE EXPCHE(IPCHEL,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/ELEMENT * ************************************************************************ * ENTREES : * * IPCHEL =POINTEUR SUR UN MCHAML * 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 * * 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 -INC SMINTE * SEGMENT QUELCO INTEGER ICO(NSOUS,NCOMX),NNCO(NSOUS) ENDSEGMENT * SEGMENT MTRA REAL*8 XE(3,NBNN1) 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 MAXIMALE 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 * 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 * * CREATION DE L'OBJET MAILLAGE CONTENANT LES POINTS SUPPORTS * NBNN=1 NBELEM=XCOOR(/1)/(IDIM+1) NBTEST=NBELEM 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 * MCHAML=ICHAML(ISOUS) SEGACT MCHAML NCOMP=NOMCHE(/2) MINTE=INFCHE(ISOUS,4) IF(MINTE.NE.0)THEN SEGACT MINTE NBNO=SHPTOT(/2) ENDIF IPT1=IMACHE(ISOUS) SEGACT IPT1 NBNN1=IPT1.NUM(/1) IF(MINTE.NE.0)SEGINI MTRA 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,NEL DO 400 IGAU=1,NBPTEL XX=VELCHE(IGAU,IB) 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 MCHELM SEGSUP QUELCO IPMAIL=0 RETURN * * MAXI OU MINI 21 IF(XX.EQ.XEXT) GO TO 403 GO TO 400 * * SUPE 23 IF(XX.GT.VALREF) GO TO 403 GO TO 400 * * EGSUPE 24 IF(XX.GE.VALREF) GO TO 403 GO TO 400 * * EGAL 25 IF(XX.EQ.VALREF) GO TO 403 GO TO 400 * * EGINFE 26 IF(XX.LE.VALREF) GO TO 403 GO TO 400 * * INFE 27 IF(XX.LT.VALREF) GO TO 403 GO TO 400 * * DIFF 28 IF(XX.NE.VALREF) GO TO 403 GO TO 400 * * COMP 29 IF((XX.GE.VALREF).AND.(XX.LE.VALRE2))GO TO 403 GO TO 400 * 403 CONTINUE NBELEM=NBELEM+1 IF(NBELEM.GT.NBTEST) THEN NBTEST=NBELEM NBELEM = NBELEM*2 SEGADJ MELEME NBELEM=NBTEST NBTEST= NUM(/2) ENDIF IF(MINTE.EQ.0)THEN NUM(1,NBELEM)=IPT1.NUM(IGAU,IB) ELSE CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE) XC=0.D0 YC=0.D0 ZC=0.D0 DO 405 IE=1,NBNN1 XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE) YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE) ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE) 405 CONTINUE NBPTS=XCOOR(/1)/(IDIM+1) NBPTS=NBPTS+1 SEGADJ MCOORD XCOOR((NBPTS-1)*(IDIM+1)+1)=XC XCOOR((NBPTS-1)*(IDIM+1)+2)=YC IF(IDIM.EQ.3) 1 XCOOR((NBPTS-1)*(IDIM+1)+3)=ZC NUM(1,NBELEM)=NBPTS 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,NEL DO 410 IGAU=1,NBPTEL XX=VELCHE(IGAU,IB) 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 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 IF(NBELEM.GT.NBTEST) THEN NBTEST=NBELEM NBELEM = NBELEM*2 SEGADJ MELEME NBELEM=NBTEST NBTEST= NUM(/2) ENDIF IF(MINTE.EQ.0)THEN NUM(1,NBELEM)=IPT1.NUM(IGAU,IB) ELSE CALL DOXE(XCOOR,IDIM,NBNN1,IPT1.NUM,IB,XE) XC=0.D0 YC=0.D0 ZC=0.D0 DO 406 IE=1,NBNN1 XC=XC+SHPTOT(1,IE,IGAU)*XE(1,IE) YC=YC+SHPTOT(1,IE,IGAU)*XE(2,IE) ZC=ZC+SHPTOT(1,IE,IGAU)*XE(3,IE) 406 CONTINUE NBPTS=XCOOR(/1)/(IDIM+1) NBPTS=NBPTS+1 SEGADJ MCOORD XCOOR((NBPTS-1)*(IDIM+1)+1)=XC XCOOR((NBPTS-1)*(IDIM+1)+2)=YC IF(IDIM.EQ.3) 1 XCOOR((NBPTS-1)*(IDIM+1)+3)=ZC NUM(1,NBELEM)=NBPTS ENDIF 410 CONTINUE SEGDES MELVAL ENDIF 310 CONTINUE * ENDIF SEGDES,MCHAML,IPT1 IF(MINTE.NE.0)SEGDES MINTE IF(MINTE.NE.0)SEGSUP MTRA * 600 CONTINUE SEGADJ MELEME SEGDES MCHELM,MELEME IF(IPLIS.NE.0)SEGSUP QUELCO RETURN END