Numérotation des lignes :

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)      ENDIFCC         ON RECUPERE LE CHAMELEMC      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

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