Numérotation des lignes :

C ENSE      SOURCE    PV        16/11/17    21:59:17     9180                 SUBROUTINE ENSE      IMPLICIT INTEGER(I-N)      IMPLICIT REAL*8(A-H,O-Z)-INC SMCHPOI-INC SMELEME-INC CCOPTIO-INC SMRIGID-INC SMMATRI-INC SMSOLUT      SEGMENT ITRAV(NENS)      integer insym      insym = 0C      CALL LIROBJ ('RIGIDITE',MRIGID,1,IRETOU)      IF(IERR.NE.0) RETURN      SEGACT MRIGID**  ON TESTE SI IL Y A DES RIGIDITES UNILATERALES*      DO 4 I=1,IRIGEL(/2)      IF(IRIGEL(6,I).NE.0) THEN      CALL ERREUR(433)      SEGDES MRIGID      RETURN      ENDIF 4    CONTINUE*      IIFO=IFORIGC      NRG = IRIGEL(/1)      NBR = IRIGEL(/2)      IF(NORINC.GT.0  .AND. NORIND.GT.0) THEN         INSYM = 1      ENDIF      IF (NRG.GE.7) THEN         DO  9 IN = 1,NBR            IANTI=IRIGEL(7,IN)            IF(IANTI.GT.0) THEN               INSYM = 1            ENDIF  9      CONTINUE      ENDIF      CALL ECROBJ ('RIGIDITE',MRIGID)      CALL RESOU      IF (IERR.NE.0) RETURN      SEGACT,MRIGID      MRISAU=MRIGID      IF (JRCOND.NE.0) THEN        MRIGID=JRCOND        SEGACT MRIGID      ENDIF      MMATRI=ICHOLE      SEGACT MMATRI      IF(NENS.EQ.0) THEN         SEGDES MMATRI         CALL ERREUR(327)         RETURN      ENDIF      MRIGID=MRISAUCC  ON MET DANS ITRAV LE NUMERO DES LIGNES OU LES MVTS D'ENSEMBLESC  ONT ETE DETECTESC      MILIGN=IILIGN      SEGACT MILIGN      SEGINI ITRAV      DO 1 I=ILIGN(/1),1,-1      LIGN=ILIGN(I)      SEGACT LIGN      DO 1501 IIJ=IMMM(/1),1,-1      IN=IMMM(IIJ)      IF(IN.EQ.0) GO TO  1501      ITRAV(IN)=IIJ +IPREL-1      IF(IN.EQ.1) GO TO 2 1501 CONTINUE      SEGDES LIGN    1 CONTINUECC  ON N'A PAS TROUVER LE NOMBRE DE MODE D'ENSEMBLE VOULUC          CALL ERREUR (5)          SEGSUP ITRAV          SEGDES MMATRI,MILIGN          RETURN    2 CONTINUECC  FABRICATION DES CHPOINT SECOND MEMBRE  BOUCLE 10C      IPT1=IGEOMA      MINCPO=IINCPO      MIDUA=IIDUA      MHARK=IHARK      MDIAG=IDIAG      SEGACT MINCPO,MIDUA,MHARK,IPT1,MDIAG      NSOUPO=1      NC=1      N=1      NBNN=1      NBELEM=1      NBREF=0      NBSOUS=0      NAT=1      DO 10 I=1,NENS      SEGINI MCHPOI      IFOPOI=IIFOC     les modes solutions sont des chpo de type diffus      JATTRI(1)=2      SEGINI MSOUPO      IPCHP(1)=MSOUPO      SEGINI MELEME      IGEOC=MELEME      ITYPEL=1CC   RECHERCHE DU NUMERO DU NOEUD ET DU NOM DE L'INCONNUES PARC   L'INTERMEDIAIRE DU TABLEAU INCPOC      IA=ITRAV(I)      DO 11 J=INCPO(/2),1,-1       j1=J      DO 11 K=1,INCPO(/1)      k1= K      IF(INCPO(K,J).EQ.IA) GO TO 12   11 CONTINUECC  ERREUR PAS NORMALEC      CALL ERREUR(5)      RETURN   12 CONTINUE      NUM(1,1)=IPT1.NUM(1,J1)      NOCOMP(1)=IDUA(K1)      NOHARM(1)=IHAR(K1)      SEGINI MPOVAL      IPOVAL=MPOVAL      VPOCHA(1,1)=DIAG(IA)      SEGDES MPOVAL,MELEME,MSOUPO,MCHPOI      ITRAV(I)=MCHPOI   10 CONTINUECC   ON VA APPELE RESOUC      SEGDES MINCPO,MIDUA,MHARK,IPT1,MDIAG      SEGDES MMATRI,MRIGID,MILIGN      DO 20 I=1,ITRAV(/1)      ITRA=ITRAV(I)      CALL ECROBJ ('CHPOINT ',ITRA)   20 CONTINUE      CALL ECROBJ ('RIGIDITE',MRIGID)      CALL ECRCHA ('ENSE')      CALL RESOU*  resou sort le nombre de modes d'ensemble      CALL LIRENT(I,1,iretou)*  et le maillage des noeuds contraints      call lirobj('MAILLAGE',ipt8,1,iretou)      IF(IERR.NE.0) RETURN      DO 21 I=1,ITRAV(/1)      CALL LIROBJ('CHPOINT ',ICHP,1,IRETOU)      IF(IERR.NE.0) THEN         CALL ERREUR(5)         RETURN      ENDIF      MCHPOI=ITRAV(I)      SEGACT MCHPOI      MSOUPO=IPCHP(1)      SEGACT MSOUPO      MELEME=IGEOC      MPOVAL=IPOVAL      SEGSUP MPOVAL,MELEME      SEGSUP MSOUPO      SEGSUP MCHPOI      ITRAV(I)=ICHP   21 CONTINUECC   ON ORTHOGONALISE LES VECTEURS LES UNS PAR RAPPORT AUX AUTRESC      DO 40 I=1,ITRAV(/1)      MCHPOI=ITRAV(I)CC  ON CALCULE LES PRODUIT XJ * XI AVEC J &lt; I  PUIS ON FAITC  XI = XI - (XJ*XI) XJC      SEGACT MCHPOI      DO 39 J = 1,IPCHP(/1)      MSOUPO=IPCHP(J)      SEGACT MSOUPO      MPOVAL=IPOVAL      SEGACT MPOVAL*MOD   39 CONTINUE      IF(I.EQ.1) GO TO 47      I1= I -1      DO 41 J = 1,I1      MCHPO1=ITRAV(J)      SEGACT MCHPO1      AA=0.D0      NSOUPO=IPCHP(/1)      DO 42 K=1,NSOUPO      MSOUPO=IPCHP(K)      MSOUP1=MCHPO1.IPCHP(K)      SEGACT MSOUP1      MPOVAL=IPOVAL      MPOVA1=MSOUP1.IPOVAL      SEGACT MPOVA1      DO 43 L=1,VPOCHA(/2)      DO 43 M=1,VPOCHA(/1)      AA=AA+VPOCHA(M,L)*MPOVA1.VPOCHA(M,L)   43 CONTINUE   42 CONTINUE      DO 44 K=1,NSOUPO      MSOUPO=IPCHP(K)      MPOVAL=IPOVAL      MSOUP1=MCHPO1.IPCHP(K)      MPOVA1=MSOUP1.IPOVAL      DO 45 L=1,VPOCHA(/2)      DO 45 M=1,VPOCHA(/1)      VPOCHA(M,L)=VPOCHA(M,L)- AA * MPOVA1.VPOCHA(M,L)  45  CONTINUE  44  CONTINUE      SEGDES MPOVA1,MSOUP1,MCHPO1  41  CONTINUE  47  CONTINUECC  ON NORME LE VECTEUR TROUVEC      BB=0.D0      DO 50 J = 1, IPCHP(/1)      MSOUPO=IPCHP(J)      MPOVAL=IPOVAL      DO 51 K=1,VPOCHA(/2)      DO 51 L=1,VPOCHA(/1)      BB = BB + VPOCHA(L,K)*VPOCHA(L,K)   51 CONTINUE   50 CONTINUE      IF( BB . EQ.0.D0 ) THEN      CALL ERREUR(5)      RETURN      ENDIF      CC = 1.D0/(SQRT(BB))      DO 52 J = 1, IPCHP(/1)      MSOUPO=IPCHP(J)      MPOVAL=IPOVAL      DO 53 K=1,VPOCHA(/2)      DO 53 L=1,VPOCHA(/1)      VPOCHA(L,K)=VPOCHA(L,K)*CC  53  CONTINUE      SEGDES MPOVAL,MSOUPO  52  CONTINUE      SEGDES MCHPOI  40  CONTINUECC  ON CREE UN OBJET SOLUT PAR MODE ET ON FUSIONNEC      DO 30 IIM=1,ITRAV(/1)      IPCH=ITRAV(IIM)      LVALM=5      NIMOD=3      NIPO=5      SEGINI MSOLUT      SEGINI MMODE      MSOLIS(4)=MMODE      MSOLIS(5)=IPCH      IMMODD(1)=IIM      MCHPOI=MSOLIS(5)      SEGACT MCHPOI      IF(IFOPOI.NE.1) GOTO 101      ICHPOI=MCHPOI      CALL NUHARM(ICHPOI,IFO,IHARM)      MCHPOI=ICHPOI      IF(IFO.NE.1) THEN         IMMODD(2)=0         IMMODD(3)=0      ELSE         IMMODD(2)=IHARM         IF(IHARM.LT.0)IMMODD(3)=1         IF(IHARM.GE.0)IMMODD(3)=2      ENDIF  101 CONTINUE      SEGDES MCHPOI      SEGDES MMODE      ITYSOL='MODE    'CCC  **** ON CREE LE NOEUD NBNO+1 QUI VA ETRE ASSOCIE AU MODE.C  **** ON MET CE NOEUD A L ORIGINE. IL VA SERVIR D INDICE AU MODEC      ZERO=0.D0      CALL CREPO1(ZERO,ZERO,ZERO,IPOIN)      NBSOUS=0      NBREF=0      NBNN=1      NBELEM=1      SEGINI MELEME      NUM(1,1)=IPOIN      ITYPEL=1      SEGDES MELEME      MSOLIS(3)=MELEMEC      N=1      DO 1100 I=4,NIPO      IF(MSOLIS(I).EQ.0)GOTO 1100      SEGINI MSOLEN      ISOLEN(1)=MSOLIS(I)      SEGDES MSOLEN      MSOLIS(I)=MSOLEN      GOTO (1100,1100,1100,1100,1101,1102,1102,1101,1101,1100),I 1101 CONTINUE      MSOLIT(I)=2      GOTO1100 1102 CONTINUE      MSOLIT(I)=5 1100 CONTINUE      SEGDES MSOLUTC      IF(IIM.EQ.1) THEN      MSOL1=MSOLUT      ELSE      CALL FUSOLU(MSOL1,MSOLUT,MSOL2)      MSOL1=MSOL2      ENDIF   30 CONTINUE      CALL ECROBJ('SOLUTION',MSOL1)      RETURN      END

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