Numérotation des lignes :

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

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