C QUESUP SOURCE CHAT 11/03/16 21:30:00 6902 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) 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 IMODEL 11 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 <> 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