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

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