Numérotation des lignes :

C QUESUP    SOURCE    GG250959  17/09/20    21:16:28     9554                 SUBROUTINE QUESUP (IPMODE,IPCHE1,ISUP,ICOND,IRET,IRET2)*______________________________________________________________________**         VERIFICATION DU LIEU SUPPORT DES MCHAML**   IPMODE  POINTEUR SUR UN OBJET MODELE (UTILISE UNIQUEMENT QUAND ISUP>0)*           DESACTIVE EN SORTIE*   IPCHE1  POINTEUR SUR LE MCHAML DONT ON SOUHAITE VERIFIER LE SUPPORT*          (LIEU DU MINTE)*   ISUP > 0  :**   ISUP    = 1 ON SOUHAITE QUE IPCHE1 SOIT AUX NOEUDS*           = 2 ON SOUHAITE QUE IPCHE1 SOIT AUX CENTRE DE GRAVITE*           = 3 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR*               LA RIGIDITE*           = 4 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR*               LA MASSE*           = 5 ON SOUHAITE QUE IPCHE1 SOIT AUX POINTS DE GAUSS POUR*               LES CONTRAINTES*   ISUP     = 0 ON VEUDRAIT CONNAITRE LE SUPPORT**   ICOND   = 0 SI LE MCHAML PEUT ETRE SUR LE SUPPORT DEMANDE OU AUX*               NOEUDS(UTILISE UNIQUEMENT QUAND ISUP >0)*             1 SI LE MCHAML DOIT ETRE IMPERATIVEMENT SUR LE SUPPORT*               VOULU (CAS NOTAMENT DES MATRICE DE HOOKES ET DES*               DES MATRICES DE HOOKES TANGENTES)*   DANS LE CAS ISUP > 0**   IRET    = 1   IPCHE1 SE TROUVE AUX NOEUDS*           = 0   IPCHE1 EST BIEN SUR LE SUPPORT DEMANDE*           = 9999 LE SUPPORT DE UNE OU PLUSIEURS SOUS ZONE N'EST*                   PAS LE BON*   DANS LE CAS ISUP = 0**   IRET    > 0   IL DONNE LE NUMERO DU SUPPORT*           = 0   LE CHAMP EST CONSTANT*           = 9999 LE CHAMELEM N'EST PAS HOMOGENE AU NIVEAU SUPPORT**   DANS TOUS LES CAS (ISUP >= 0)**   IRET2   > 0   IL DONNE LE NUMERO DU SUPPORT*           = 9999 LE CHAMELEM N'EST PAS HOMOGENE AU NIVEAU SUPPORT*                  OU SI LE TABLEAU INFCHE NE CONTIENT PAS CETTE*                  INFORMATION**   REMARQUE : SI IPCHE1 EST AUX NOEUDS LE PASSAGE DES VALEURS SUR LE*              SUPPORT VOULU SE FAIT DANS VALCHE ET/OU VALMEL SAUF DANS*              LE CAS DES MATRICE DE HOOKES**   CAMPENON JM LE  02/91**pv  on ne desactivee pas car ca va resservir tres bientot**_______________________________________________________________________*      IMPLICIT INTEGER(I-N)       IMPLICIT REAL*8(A-H,O-Z)-INC CCOPTIO-INC SMCHAML-INC SMINTE-INC SMMODEL*      SEGMENT INFO       INTEGER INFELL(JG)      ENDSEGMENT*      CHARACTER*16 CONCH *--------- Fin des déclarations ----------------------       IRET=0      IRET2=0      ICONST=1*      MCHELM=IPCHE1      SEGACT MCHELM      NSOUS=ICHAML(/1)      N3=INFCHE(/2)**    Recherche de l'information sur le support stockée dans INFCHE(*,6) ...*      IF(N3.GE.6) THEN         IRET2=INFCHE(1,6)         DO 9 ISOUS=2,NSOUS            IF(INFCHE(ISOUS,6).NE.IRET2) IRET2=9999  9      CONTINUE      ELSE         IRET2=9999      ENDIF**   si le chamelem est constant sur l'element quelque soit le*   support demande  on est bon*      DO  10 ISOUS=1,NSOUS       MCHAML=ICHAML(ISOUS)       SEGACT MCHAML       NCOMP=IELVAL(/1)        DO 20 ICOMP=1,NCOMP         MELVAL=IELVAL(ICOMP)         IF(MELVAL.NE.0)THEN          SEGACT MELVAL          IF(TYPCHE(ICOMP)(1:8).NE.'POINTEUR')THEN            IPOIN=VELCHE(/1)          ELSE            IPOIN=IELCHE(/1)          ENDIF          IF(IPOIN.NE.1)THEN*pv        SEGDES MELVAL,MCHAML           ICONST=0           GOTO 500          ENDIF*pv       SEGDES MELVAL         ENDIF  20   CONTINUE*pv    SEGDES MCHAML  10  CONTINUE* 500  CONTINUE      IF (N3.LT.4) GOTO 1000      IF(N3.GE.6) THEN        ISUP1=INFCHE(1,6)        IF (ICONST.EQ.1) GOTO 666      ELSE        GOTO 3000      ENDIF*      IFLAG=0**   CAS ISUP = 0*   ------------*      IF(ISUP.EQ.0)THEN        IF(N3.GE.6)ISUP1=INFCHE(1,6)        DO 1 ISOUS=1,NSOUS*        write (6,*) ' isous n3 infche4 ',isous,n3,infche(isous,4)         IF (INFCHE(ISOUS,4).EQ.0) GOTO 1         IF (N3.GE.6) THEN            INFCH=INFCHE(ISOUS,6)*           write (6,*) ' infch isup1 ',infch,isup1            IF (INFCH.EQ.1) GOTO 1            IF (INFCH.NE.ISUP1) THEN                MINTE=INFCHE(1,4)                MINTE1=INFCHE(ISOUS,4)                SEGACT MINTE                SEGACT MINTE1                NBPGAU=POIGAU(/1)                NBPGA1=MINTE1.POIGAU(/1)*pv             SEGDES,MINTE,MINTE1                IF(NBPGAU.EQ.NBPGA1)THEN                  IFLAG=IFLAG+1                ELSE                  GOTO 2000                ENDIF            ELSE               IFLAG=IFLAG+1            ENDIF         ELSE            GOTO 3000         ENDIF 1    CONTINUE**       TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT*        IF (IFLAG.EQ.0) GOTO 1000        IF (IFLAG.EQ.NSOUS) THEN           IF(ISUP.EQ.0) THEN               IRET=ISUP1           ENDIF           GOTO 666        ELSE           GOTO 2000        ENDIF**    CAS ISUP > 0*    ------------*    DANS CE CAS CE SONT LES ZONES DU MODELE QUI PILOTENT*      ELSE        ISUP1=ISUP**       ACTIVATION DU MODELE*        MMODEL=IPMODE        SEGACT MMODEL        NSOUM=KMODEL(/1)        DO 11 ISOUM=1,NSOUM          IMODEL=KMODEL(ISOUM)          SEGACT IMODEL          MELE=NEFMOD          if ((mele.eq.22).or.(mele.eq.259)) then            segdes imodel            go to 11          endif**         BOUCLE SUR LES ZONES DU CHAMELEM*          DO 2 ISOUS=1,NSOUS            CONCH=CONCHE(ISOUS)            IPMAIL=IMACHE(ISOUS)*           write (6,*) ' isous,imamod ipmail conch conmod infche4 ',*    >             isous,imamod,ipmail,conch,conmod,infche(isous,4)            IF(IMAMOD.NE.IPMAIL.OR.CONCH.NE.CONMOD)GOTO 2             IF (INFCHE(ISOUS,4).EQ.0) GOTO 2*             IF (N3.GE.6) THEN               INFCH=INFCHE(ISOUS,6)               IF (INFCH.EQ.1) GOTO 2               IF (INFCH.NE.ISUP1) THEN                  IF(ISUP1.EQ.6)THEN                    CALL TSHAPE(MELE,'GAUSS',IPMIN1)                  ELSE                    If(infmod(/1).lt.2+isup1) then                    CALL ELQUOI(MELE,0,ISUP1,IPINF,IMODEL)                    IF(IERR.NE.0) THEN                      IRET=9999                      SEGDES IMODEL                      SEGDES MMODEL                      GOTO 666                    ENDIF                    INFO=IPINF                    IPMIN1=INFELL(11)                    segsup info                    else                    ipmin1=infmod(2+isup1)                    endif                   ENDIF                  MINTE=INFCHE(ISOUS,4)                  MINTE1=IPMIN1                  SEGACT MINTE                  SEGACT MINTE1                  NBPGAU=POIGAU(/1)                  NBPGA1=MINTE1.POIGAU(/1)                  IF(NBPGAU.EQ.NBPGA1)THEN                    IRT=1                  ELSE                    IRT=0                  ENDIF*pv               SEGDES MINTE,MINTE1                  IF(IRT.EQ.1)THEN                    IFLAG=IFLAG+1                  ELSE*pv                 SEGDES IMODEL*pv                 SEGDES MMODEL                    GOTO 2000                  ENDIF               ELSE                 IFLAG=IFLAG+1               ENDIF           ELSE*pv          SEGDES IMODEL*pv          SEGDES MMODEL             GOTO 3000           ENDIF 2      CONTINUE*pv   SEGDES IMODEL11    CONTINUE*pv   SEGDES MMODEL**       TOUTES LES SOUS ZONES DOIVENT ETRE SUR LE BON SUPPORT**       write (6,*) ' quesup iflag isup nsous ',iflag,isup,nsous        IF (IFLAG.EQ.0) GOTO 1000        IF (IFLAG.EQ.NSOUS) THEN           IF(ISUP.EQ.0) THEN               IRET=ISUP1           ENDIF           GOTO 666        ELSE           GOTO 2000        ENDIF      ENDIF* 1000 CONTINUE**     IPCHE1 EST AUX NOEUDS*      IRET=1      IF (ISUP.EQ.1) IRET=0      IF (ICOND.EQ.1.AND.IRET.EQ.1.AND.ISUP.NE.0) GOTO 2000      GOTO 666* 2000 CONTINUE*      IF(ISUP.NE.0)THEN**     IPCHE1 EST SUR UN AUTRE SUPPORT QUE CELUI VOULU ET PAS AUX NOEUDS**     ==> MESSAGE D'ERREUR POUR QUE L'ON DONNE LE CHAMELEM SUR UN*         SUPPORT CORRECT*        MOTERR(1:8)=TITCHE        CALL ERREUR(124)      ELSE**  LES DIFFERENTS SOUS-ZONES DU CHAMELEM ONT DES POINTS SUPPORTS DIFFERENTS*         CALL ERREUR(560)      ENDIF      SEGDES MCHELM      IRET=9999      RETURN* 3000 CONTINUE**     IPCHE1 A UN POINTEUR SUR UN MINTE &lt;> 0 MAIS L'INFCHE(..,6)*     N'EST PAS RENSEIGNE (NE DOIT PAS ARRIVER NORMALEMENT)*      IRET=9999      CALL ERREUR(53)* 666  CONTINUE*pv   SEGDES MCHELM      RETURN      END

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