Télécharger la plaquette Cast3M


fr en

Télécharger ense.eso

Retour à la liste

Numérotation des lignes : 

ense

  1. C ENSE      SOURCE    CB215821  25/04/23    21:15:19     12247          
  2.       SUBROUTINE ENSE
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. -INC SMCHPOI
  6. -INC SMELEME
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMRIGID
  11. -INC SMCOORD
  12. -INC SMMATRI
  13. -INC SMSOLUT
  14.       SEGMENT ITRAV(NENS)
  15.       integer insym
  16.       insym = 0
  17. C
  18.       CALL LIROBJ ('RIGIDITE',MRIGID,1,IRETOU)
  19.       IF(IERR.NE.0) RETURN
  20.       SEGACT MRIGID
  21. *
  22. *  ON TESTE SI IL Y A DES RIGIDITES UNILATERALES
  23. *
  24.       DO 4 I=1,IRIGEL(/2)
  25.       IF(IRIGEL(6,I).NE.0) THEN
  26.       CALL ERREUR(433)
  27.       SEGDES MRIGID
  28.       RETURN
  29.       ENDIF
  30.  4    CONTINUE
  31. *
  32.       IIFO=IFORIG
  33. C
  34.       NRG = IRIGEL(/1)
  35.       NBR = IRIGEL(/2)
  36.       IF(NORINC.GT.0  .AND. NORIND.GT.0) THEN
  37.          INSYM = 1
  38.       ENDIF
  39.       IF (NRG.GE.7) THEN
  40.          DO  9 IN = 1,NBR
  41.             IANTI=IRIGEL(7,IN)
  42.             IF(IANTI.GT.0) THEN
  43.                INSYM = 1
  44.             ENDIF
  45.   9      CONTINUE
  46.       ENDIF
  47.       CALL ECROBJ ('RIGIDITE',MRIGID)
  48.       CALL RESOU
  49.       IF (IERR.NE.0) RETURN
  50.       SEGACT,MRIGID
  51.       MRISAU=MRIGID
  52.  300  continue
  53.       IF (JRCOND.NE.0) THEN
  54.         MRIGID=JRCOND
  55.         SEGACT MRIGID
  56.       ENDIF
  57.       if(ichole.eq.0.and.jrcond.ne.0) goto 300
  58.       MMATRI=ICHOLE
  59.       SEGACT MMATRI
  60.       IF(NENS.EQ.0) THEN
  61.          SEGDES MMATRI
  62.          CALL ERREUR(327)
  63.          RETURN
  64.       ENDIF
  65.       MRIGID=MRISAU
  66. C
  67. C  ON MET DANS ITRAV LE NUMERO DES LIGNES OU LES MVTS D'ENSEMBLES
  68. C  ONT ETE DETECTES
  69. C
  70.       MILIGN=IILIGN
  71.       SEGACT MILIGN
  72.       SEGINI ITRAV
  73.       DO 1 I=ILIGN(/1),1,-1
  74.       LIGN=ILIGN(I)
  75.       SEGACT LIGN
  76.       DO 1501 IIJ=IMMM(/1),1,-1
  77.       IN=IMMM(IIJ)
  78.       IF(IN.EQ.0) GO TO  1501
  79.       ITRAV(IN)=IIJ +IPREL-1
  80.       IF(IN.EQ.1) GO TO 2
  81.  1501 CONTINUE
  82.       SEGDES LIGN
  83.     1 CONTINUE
  84. C
  85. C  ON N'A PAS TROUVER LE NOMBRE DE MODE D'ENSEMBLE VOULU
  86. C
  87.           CALL ERREUR (5)
  88.           SEGSUP ITRAV
  89.           SEGDES MMATRI,MILIGN
  90.           RETURN
  91.     2 CONTINUE
  92. C
  93. C  FABRICATION DES CHPOINT SECOND MEMBRE  BOUCLE 10
  94. C
  95.       IPT1=IGEOMA
  96.       MINCPO=IINCPO
  97.       MIDUA=IIDUA
  98.       MHARK=IHARK
  99.       MDIAG=IDIAG
  100.       SEGACT MINCPO,MIDUA,MHARK,IPT1,MDIAG
  101.       NSOUPO=1
  102.       NC=1
  103.       N=1
  104.       NBNN=1
  105.       NBELEM=1
  106.       NBREF=0
  107.       NBSOUS=0
  108.       NAT=1
  109.       DO 10 I=1,NENS
  110.       SEGINI MCHPOI
  111.       IFOPOI=IIFO
  112. C     les modes solutions sont des chpo de type diffus
  113.       JATTRI(1)=2
  114.       SEGINI MSOUPO
  115.       IPCHP(1)=MSOUPO
  116.       SEGINI MELEME
  117.       IGEOC=MELEME
  118.       ITYPEL=1
  119. C
  120. C   RECHERCHE DU NUMERO DU NOEUD ET DU NOM DE L'INCONNUES PAR
  121. C   L'INTERMEDIAIRE DU TABLEAU INCPO
  122. C
  123.       IA=ITRAV(I)
  124.       DO    J=INCPO(/2),1,-1
  125.        j1=J
  126.       DO    K=1,INCPO(/1)
  127.       k1= K
  128.       IF(INCPO(K,J).EQ.IA) GO TO 12
  129.       ENDDO
  130.       ENDDO
  131. C
  132. C  ERREUR PAS NORMALE
  133. C
  134.       CALL ERREUR(5)
  135.       RETURN
  136.    12 CONTINUE
  137.       NUM(1,1)=IPT1.NUM(1,J1)
  138.       NOCOMP(1)=IDUA(K1)
  139.       NOHARM(1)=IHAR(K1)
  140.       SEGINI MPOVAL
  141.       IPOVAL=MPOVAL
  142.       VPOCHA(1,1)=DIAG(IA)
  143.       SEGDES MPOVAL,MELEME,MSOUPO,MCHPOI
  144.       ITRAV(I)=MCHPOI
  145.    10 CONTINUE
  146. C
  147. C   ON VA APPELE RESOU
  148. C
  149.       SEGDES MINCPO,MIDUA,MHARK,IPT1,MDIAG
  150.       SEGDES MMATRI,MRIGID,MILIGN
  151.       DO 20 I=1,ITRAV(/1)
  152.       ITRA=ITRAV(I)
  153.       CALL ECROBJ ('CHPOINT ',ITRA)
  154.    20 CONTINUE
  155.       CALL ECROBJ ('RIGIDITE',MRIGID)
  156.       CALL ECRCHA ('ENSE')
  157.       CALL RESOU
  158. *  resou sort le nombre de modes d'ensemble
  159.       CALL LIRENT(I,1,iretou)
  160.       IF(IERR.NE.0) RETURN
  161.       DO 21 I=1,ITRAV(/1)
  162.       CALL LIROBJ('CHPOINT ',ICHP,1,IRETOU)
  163.       IF(IERR.NE.0) THEN
  164.          CALL ERREUR(5)
  165.          RETURN
  166.       ENDIF
  167.       MCHPOI=ITRAV(I)
  168.       SEGACT MCHPOI
  169.       MSOUPO=IPCHP(1)
  170.       SEGACT MSOUPO
  171.       MELEME=IGEOC
  172.       MPOVAL=IPOVAL
  173.       SEGSUP MPOVAL,MELEME
  174.       SEGSUP MSOUPO
  175.       SEGSUP MCHPOI
  176.       ITRAV(I)=ICHP
  177.    21 CONTINUE
  178. *  et le champoint des indeterminations activees
  179.       call lirobj('CHPOINT ',mchpo4,1,iretou)
  180. C
  181. C   ON ORTHOGONALISE LES VECTEURS LES UNS PAR RAPPORT AUX AUTRES
  182. C
  183.       DO 40 I=1,ITRAV(/1)
  184.       MCHPOI=ITRAV(I)
  185. C
  186. C  ON CALCULE LES PRODUIT XJ * XI AVEC J < I  PUIS ON FAIT
  187. C  XI = XI - (XJ*XI) XJ
  188. C
  189.       SEGACT MCHPOI
  190.       DO 39 J = 1,IPCHP(/1)
  191.       MSOUPO=IPCHP(J)
  192.       SEGACT MSOUPO
  193.       MPOVAL=IPOVAL
  194.       SEGACT MPOVAL*MOD
  195.    39 CONTINUE
  196.       IF(I.EQ.1) GO TO 47
  197.       I1= I -1
  198.       DO 41 J = 1,I1
  199.       MCHPO1=ITRAV(J)
  200.       SEGACT MCHPO1
  201.       AA=0.D0
  202.       NSOUPO=IPCHP(/1)
  203.       DO 42 K=1,NSOUPO
  204.       MSOUPO=IPCHP(K)
  205.       MSOUP1=MCHPO1.IPCHP(K)
  206.       SEGACT MSOUP1
  207.       MPOVAL=IPOVAL
  208.       MPOVA1=MSOUP1.IPOVAL
  209.       SEGACT MPOVA1
  210.       DO    L=1,VPOCHA(/2)
  211.       DO    M=1,VPOCHA(/1)
  212.       AA=AA+VPOCHA(M,L)*MPOVA1.VPOCHA(M,L)
  213.       ENDDO
  214.       ENDDO
  215.    42 CONTINUE
  216.       DO 44 K=1,NSOUPO
  217.       MSOUPO=IPCHP(K)
  218.       MPOVAL=IPOVAL
  219.       MSOUP1=MCHPO1.IPCHP(K)
  220.       MPOVA1=MSOUP1.IPOVAL
  221.       DO    L=1,VPOCHA(/2)
  222.       DO    M=1,VPOCHA(/1)
  223.       VPOCHA(M,L)=VPOCHA(M,L)- AA * MPOVA1.VPOCHA(M,L)
  224.       ENDDO
  225.       ENDDO
  226.   44  CONTINUE
  227.       SEGDES MPOVA1,MSOUP1,MCHPO1
  228.   41  CONTINUE
  229.   47  CONTINUE
  230. C
  231. C  ON NORME LE VECTEUR TROUVE
  232. C
  233.       BB=0.D0
  234.       DO 50 J = 1, IPCHP(/1)
  235.       MSOUPO=IPCHP(J)
  236.       MPOVAL=IPOVAL
  237.       DO  K=1,VPOCHA(/2)
  238.       DO  L=1,VPOCHA(/1)
  239.       BB = BB + VPOCHA(L,K)*VPOCHA(L,K)
  240.       ENDDO
  241.       ENDDO
  242.    50 CONTINUE
  243.       IF( BB . EQ.0.D0 ) THEN
  244.       CALL ERREUR(5)
  245.       RETURN
  246.       ENDIF
  247.       CC = 1.D0/(SQRT(BB))
  248.       DO 52 J = 1, IPCHP(/1)
  249.       MSOUPO=IPCHP(J)
  250.       MPOVAL=IPOVAL
  251.       DO K=1,VPOCHA(/2)
  252.       DO L=1,VPOCHA(/1)
  253.       VPOCHA(L,K)=VPOCHA(L,K)*CC
  254.       ENDDO
  255.       ENDDO
  256.       SEGDES MPOVAL,MSOUPO
  257.   52  CONTINUE
  258.       SEGDES MCHPOI
  259.   40  CONTINUE
  260. C
  261. C  ON CREE UN OBJET SOLUT PAR MODE ET ON FUSIONNE
  262. C
  263.       DO 30 IIM=1,ITRAV(/1)
  264.       IPCH=ITRAV(IIM)
  265.       LVALM=5
  266.       NIMOD=3
  267.       NIPO=5
  268.       SEGINI MSOLUT
  269.       SEGINI MMODE
  270.       MSOLIS(4)=MMODE
  271.       MSOLIS(5)=IPCH
  272.       IMMODD(1)=IIM
  273.       MCHPOI=MSOLIS(5)
  274.       SEGACT MCHPOI
  275.       IF(IFOPOI.NE.1) GOTO 101
  276.       ICHPOI=MCHPOI
  277.       CALL NUHARM(ICHPOI,IFO,IHARM)
  278.       MCHPOI=ICHPOI
  279.       IF(IFO.NE.1) THEN
  280.          IMMODD(2)=0
  281.          IMMODD(3)=0
  282.       ELSE
  283.          IMMODD(2)=IHARM
  284.          IF(IHARM.LT.0)IMMODD(3)=1
  285.          IF(IHARM.GE.0)IMMODD(3)=2
  286.       ENDIF
  287.   101 CONTINUE
  288.       SEGDES MCHPOI
  289.       SEGDES MMODE
  290.       ITYSOL='MODE    '
  291. C
  292. C
  293. C  **** ON CREE LE NOEUD NBNO+1 QUI VA ETRE ASSOCIE AU MODE.
  294. C  **** ON MET CE NOEUD A L ORIGINE. IL VA SERVIR D INDICE AU MODE
  295. C
  296.       ZERO=0.D0
  297.       CALL CREPO1(ZERO,ZERO,ZERO,IPOIN)
  298.       NBSOUS=0
  299.       NBREF=0
  300.       NBNN=1
  301.       NBELEM=1
  302.       SEGINI MELEME
  303.       NUM(1,1)=IPOIN
  304.       ITYPEL=1
  305.       SEGDES MELEME
  306.       MSOLIS(3)=MELEME
  307. C
  308.       N=1
  309.       DO 1100 I=4,NIPO
  310.       IF(MSOLIS(I).EQ.0)GOTO 1100
  311.       SEGINI MSOLEN
  312.       ISOLEN(1)=MSOLIS(I)
  313.       SEGDES MSOLEN
  314.       MSOLIS(I)=MSOLEN
  315.       GOTO (1100,1100,1100,1100,1101,1102,1102,1101,1101,1100),I
  316.  1101 CONTINUE
  317.       MSOLIT(I)=2
  318.       GOTO1100
  319.  1102 CONTINUE
  320.       MSOLIT(I)=5
  321.  1100 CONTINUE
  322.       SEGDES MSOLUT
  323. C
  324.       IF(IIM.EQ.1) THEN
  325.       MSOL1=MSOLUT
  326.       ELSE
  327.       CALL FUSOLU(MSOL1,MSOLUT,MSOL2)
  328.       MSOL1=MSOL2
  329.       ENDIF
  330.    30 CONTINUE
  331.       CALL ECROBJ('SOLUTION',MSOL1)
  332.       RETURN
  333.       END
  334.  
  335.  
  336.  
  337.  
  338.  
  339.  
  340.  
  341.  
  342.  
  343.  
  344.  
  345.  
  346.  
  347.  
  348.  
  349.  
  350.  
  351.  
  352.  
  353.  
  354.  
  355.  
  356.  
  357.  

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