Télécharger la plaquette Cast3M


fr en

Télécharger rglili.eso

Retour à la liste

Numérotation des lignes : 

rglili

  1. C RGLILI    SOURCE    PV090527  26/04/28    21:16:15     12529          
  2.       SUBROUTINE RGLILI(ISOLS,ISTRU,IRIG,IRET)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C CE SUBROUTINE CALCULE POUR LES SOLUTIONS STATIQUES ISOLS DE TYPE :
  7. C  1-MECA OU FLUI
  8. C LES RIGIDITES DE COUPLAGE DES LIAISONS ENTRE ELLES (FORMALISME GIBERT)
  9. C DE SOUS TYPE MASSE SI IRIG=1, DE SOUS TYPE RIGIDITE SI IRIG=2
  10. C ECRIT PAR FARVACQUE
  11. C  2-DEPI
  12. C UNE MATRICE DE RIGIDITE NULLE ET UNE MATRICE DE MASSE IDENTITE
  13. C (FORMALISME DEPLACEMENTS IMPOSES SUR MODES BLOQUES POUR DEVO)
  14. C ECRIT PAR GUILBAUD
  15. C
  16. C ELLES S'APPUIENT SUR L ELEMENT QUI CONTIENT TOUS LES POINTS ASSOCIES
  17. C AUX LIAISONS MJONCT.
  18. C
  19. C APPELE PAR RIGI,RGBASE
  20. C APPELLE : ETALPR,MUCPRI,ETALCH,YTMX,ERREUR(235,108)
  21. C=======================================================================
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC SMSOLUT
  26. -INC SMRIGID
  27. -INC SMCOORD
  28. -INC SMATTAC
  29. -INC SMELEME
  30. -INC SMSTRUC
  31. -INC CCHAMP
  32.       SEGMENT ICPR(nbpts)
  33.  
  34.       SEGMENT IINC
  35.        CHARACTER*(LOCOMP) CIINC(0)
  36.       ENDSEGMENT
  37.       SEGMENT IIDU
  38.        CHARACTER*(LOCOMP) CIIDU(NNI1)
  39.       ENDSEGMENT
  40.  
  41.       SEGMENT ITRMEC(NJONC)
  42.       SEGMENT ITRDEP(NJONC)
  43.       SEGMENT ITRAV(6)
  44.       SEGMENT/MVA/(VA(NNI1,IPR1)*D),MVA1.MVA
  45.       SEGMENT/ICONTR/(MCONTR(NNI1,IPR1))
  46.       SEGMENT IPB(IPR1)
  47.       DATA KZERO/0/
  48.  
  49.       CHARACTER*(LOCOMP) IDDL
  50. C
  51.       IRET=0
  52.       IF(IRIG.NE.1.AND.IRIG.NE.2) GOTO 8000
  53.       MSOSTU=ISTRU
  54.       MSOLUT=ISOLS
  55.       SEGACT MSOLUT
  56.       NIPO=MSOLIS(/1)
  57.       KJONC=MSOLIS(10)
  58.       KDEPL=MSOLIS(5)
  59.       IF(KDEPL.NE.0) GO TO 12
  60.       MOTERR(1:8)='SOLUTION'
  61.       MOTERR(9:26)='SOLUTION'
  62.       MOTERR(30:38)='DEPL'
  63.       SEGDES MSOLUT
  64.       CALL ERREUR(235)
  65. C     ON NE TROUVE PAS LES DEPL
  66.       GO TO 8000
  67.  12   CONTINUE
  68.       SEGDES MSOLUT
  69.       MSOLE1=KJONC
  70.       SEGACT MSOLE1
  71.       NJONC=MSOLE1.ISOLEN(/1)
  72.       SEGDES MSOLE1
  73.       IF(NJONC.EQ.0) GO TO 8000
  74. C
  75.       SEGINI ITRMEC,ITRDEP
  76.       SEGACT MSOLE1
  77.       NJOMEC=0
  78.       NJODEP=0
  79.       DO 20 I=1,NJONC
  80.       MJONCT=MSOLE1.ISOLEN(I)
  81.       SEGACT MJONCT
  82.       IF(MJOTYP.EQ.'MECA'.OR.MJOTYP.EQ.'FLUI') THEN
  83.         NJOMEC=NJOMEC+1
  84.         ITRMEC(NJOMEC)=I
  85.       ELSEIF(MJOTYP.EQ.'DEPI'.AND.IRIG.EQ.1) THEN
  86.         NJODEP=NJODEP+1
  87.         ITRDEP(NJODEP)=I
  88.       ENDIF
  89.       SEGDES MJONCT
  90.  20   CONTINUE
  91.       SEGDES MSOLE1
  92.       IF(NJOMEC.EQ.0.AND.NJODEP.EQ.0) GOTO 7000
  93.       IF(NJOMEC.EQ.0) GO TO 5000
  94. C
  95. C  **** INITIALISATION DE LA GEOMETRIE(1 ELEMENT QUI CONTIENT TOUS LES
  96. C  **** POINT-LIAISONS) ET DE LA MATRICE ASSOCIEE XMATRI
  97. C  **** INITIALISATION DE IMATRI ET DE DESCR
  98. C
  99.       NJONC=NJOMEC
  100.       LVAL=NJONC*(NJONC+1)/2
  101.       NLIGRP=NJONC
  102.       NLIGRD=NJONC
  103.       nelrig=1
  104.       rigrel=0
  105.       SEGINI XMATRI
  106. *      NLIGRE=NJONC
  107.       SEGINI DESCR
  108.       NELRIG=1
  109. *      SEGINI IMATRI
  110. *      IMATTT(1)=XMATRI
  111. *      SEGDES IMATRI
  112.       SEGACT MSOLUT
  113.       IPT1=MSOLIS(3)
  114.       SEGACT IPT1
  115.       NBSOUS=0
  116.       NBREF=0
  117.       NBNN=NJONC
  118.       NBELEM=1
  119.       SEGINI MELEME
  120.       ITYPEL=27
  121.       MSOLEN=KDEPL
  122. C
  123. C  **** PREPARATION DES OPERATIONS : A IPM ON DONNE LA FORME RECTANGLE
  124. C
  125.       SEGACT MSOLEN
  126.       IPM=ISOLEN(1)
  127.       CALL ETALPR(IPM,KIINC,KICPR,KCONTR)
  128.       ICONTR=KCONTR
  129.       SEGACT ICONTR
  130.       IPR1=MCONTR(/2)
  131.       NNI1=MCONTR(/1)
  132.       SEGINI MVA
  133.       KMVA=MVA
  134.       SEGINI MVA
  135.       KMVB=MVA
  136.       SEGINI IPB
  137.       KIPB=IPB
  138.       IINC=KIINC
  139.       SEGACT IINC
  140.       SEGINI IIDU
  141.       DO 50 I=1,NNI1
  142.       IDDL=CIINC(I)
  143.       DO 51 J=1,LNOMDD
  144.       IF(IDDL.NE.NOMDD(J)) GOTO 51
  145.       CIIDU(I)=NOMDU(J)
  146.       GOTO 50
  147.  51   CONTINUE
  148.       MOTERR=IDDL
  149.       CALL ERREUR(108)
  150. C     ON NE TROUVE PAS IDDL DANS CCHAMP
  151.       GOTO 7000
  152.  50   CONTINUE
  153.       KINCDU=IIDU
  154.       IF(IIMPI.NE.0)WRITE(6,8883)(CIINC(I),CIIDU(I),I=1,NNI1)
  155.  8883 FORMAT(20(1X,A4))
  156. C
  157. C  **** CAS IRIG=1 : TERMES DANS LA MATRICE MASSE : UT.M.U
  158. C
  159.       IF(IRIG.NE.1) GO TO 100
  160.       SEGACT MSOSTU
  161.       MATMAS=ISMASS
  162.       SEGDES MSOSTU
  163.       SEGACT MSOLE1,MSOLEN
  164.       LTAB=ISOLEN(/1)
  165.       DO 9 I=1,NJONC
  166.       MJONCT=MSOLE1.ISOLEN(ITRMEC(I))
  167.       SEGACT MJONCT
  168.       NOELEP(I)=I
  169.       NOELED(I)=I
  170.       IF(MJODDL.EQ.'LX  ') GO TO 16
  171.       LISINC(I)='FBET'
  172.       LISDUA(I)='BETA'
  173.       GO TO 17
  174.  16   LISINC(I)='BETA'
  175.       LISDUA(I)='FBET'
  176.  17   CONTINUE
  177.       SEGDES MJONCT
  178.       NUM(I,1)=IPT1.NUM(1,ITRMEC(I))
  179.  9    CONTINUE
  180. C
  181.       KZERO=0
  182.       DO 10 I=1,NJONC
  183.       IP1=ISOLEN(I)
  184.       CALL MUCPRI(IP1,MATMAS,MUI)
  185.       IF(IERR.NE.0) GOTO 8000
  186.       CALL ETALCH(MUI,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
  187.       IF(IERR.NE.0) GO TO 8000
  188. C
  189.       IF(IIMPI.EQ.0) GOTO 804
  190.       MVA=KMVB
  191.       IPB=KIPB
  192.       SEGACT MVA,IPB
  193.       WRITE(IOIMP,7878)I
  194.  7878 FORMAT('  ************* DANS RGLILI CALCUL DE UJ.M.UI ****',
  195.      1 /,' ========== I=',I4,' ECRITURE DE M.UI SOUS LA FORME VA
  196.      1 PUIS IPB')
  197.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  198.       WRITE(IOIMP,8882)(IPB(KJ2),KJ2=1,IPR1)
  199.  804  CONTINUE
  200. C
  201.       DO 11 J=I,NJONC
  202.       IP2=ISOLEN(J)
  203.       CALL ETALCH(IP2,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
  204.       IF(IERR.NE.0) GOTO 8000
  205. C
  206.       IF(IIMPI.EQ.0) GO TO 803
  207.       MVA=KMVA
  208.       SEGACT MVA
  209.       WRITE(IOIMP,7879)J
  210.  7879 FORMAT(' ========== J=',I4,' ECRITURE DE UJ SOUS LA FORME VA')
  211.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  212.  803  CONTINUE
  213. C
  214. C  **** OPERATION UT . ( M.U )
  215. C
  216.       MVA=KMVA
  217.       MVA1=KMVB
  218.       IPB=KIPB
  219. C      SEGACT MVA,MVA1,IPB
  220.       XRET=0.
  221.       DO    J1=1,NPR2
  222.       JJ1=IPB(J1)
  223.       DO    I1=1,NNI1
  224.       XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
  225.       enddo    
  226.       enddo    
  227. C
  228.       IF(IIMPI.EQ.0) GOTO 805
  229.       CALL YTMX(IP1,IP2,MATMAS,WW)
  230.       WRITE(IOIMP,7877)XRET,WW
  231.  7877 FORMAT(' UI.M.UJ = ',E12.5,'   PAR L''OPERATEUR YTMX ON TROUVE '
  232.      1 ,E12.5)
  233.   805 CONTINUE
  234. C
  235. *      K=(J*(J-1)/2)+I
  236.       RE(J,I,1)=XRET
  237.       RE(I,J,1)=XRET
  238.  11   CONTINUE
  239.  10   CONTINUE
  240.       GO TO 6
  241. C
  242. C  ****  CAS IRIG=2 : MATRICE RAIDEUR : LIGNE J COLONNE I: UI ET PJ
  243. C
  244.  100  CONTINUE
  245. C
  246. C  **** PREMIERE BOUCLE SUR LESMJONCT. ON EN SORT MCHPOI QU ON ETALE
  247. C  **** DANS MVA . C EST UI
  248. C
  249.       SEGACT MSOLEN,MSOLE1
  250.       LTAB=ISOLEN(/1)
  251.       DO 30 IJO1=1,NJONC
  252.       MJONCT=MSOLE1.ISOLEN(ITRMEC(IJO1))
  253.       SEGACT MJONCT
  254.       RLIBRE=1.
  255.       IF(MJODDL.EQ.'FLX ') RLIBRE=-1.
  256.       NOELEP(IJO1)=IJO1
  257.       NOELED(IJO1)=IJO1
  258.       IF(MJODDL.EQ.'LX  ') GO TO 18
  259.       LISINC(IJO1)='FBET'
  260.       LISDUA(IJO1)='BETA'
  261.       GO TO 19
  262.  18   LISINC(IJO1)='BETA'
  263.       LISDUA(IJO1)='FBET'
  264.  19   CONTINUE
  265.       NUM(IJO1,1)=IPT1.NUM(1,ITRMEC(IJO1))
  266.       SEGDES MJONCT
  267.       IP1=ISOLEN(ITRMEC(IJO1))
  268.       KZERO=0
  269.       CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
  270.       IF(IERR.NE.0) GO TO 8000
  271.       IF(IIMPI.EQ.0) GO TO 800
  272.       MVA=KMVA
  273.       SEGACT MVA
  274.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  275.  8880 FORMAT(8(2X,E12.5))
  276.  800  CONTINUE
  277. C
  278. C  **** 2IEME BOUCLE SUR LES MJONCT: ON EN TIRE PJ QU ON ETALE DANS MVB
  279. C
  280.       DO 31 IJO2=IJO1,NJONC
  281.       MJONCT=MSOLE1.ISOLEN(ITRMEC(IJO2))
  282.       SEGACT MJONCT
  283.       NST=ISTRJO(/1)
  284.       DO 32 IS=1,NST
  285.       IF(ISTRJO(IS).NE.MSOSTU) GO TO 32
  286.       IPP2=IPCHJO(IS)
  287.       CALL ETALCH(IPP2,KIINC,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
  288.       IF(IERR.NE.0) GO TO 8000
  289.       IF(IIMPI.EQ.0) GO TO 801
  290.       MVA=KMVB
  291.       IPB=KIPB
  292.       SEGACT MVA,IPB
  293.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  294.       WRITE(IOIMP,8882)(IPB(KJ2),KJ2=1,IPR1)
  295.  8882 FORMAT( 10I6)
  296.  801  CONTINUE
  297. C
  298. C  **** OPERATION VA*VB
  299. C
  300.       MVA=KMVA
  301.       MVA1=KMVB
  302.       IPB=KIPB
  303. C      SEGACT MVA,MVA1,IPB
  304. C
  305.       XRET=0.
  306.       DO    J1=1,NPR2
  307.       JJ1=IPB(J1)
  308.       DO    I1=1,NNI1
  309.       XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
  310.       enddo    
  311.       enddo    
  312. C
  313. *      K=(IJO2*(IJO2-1)/2)+IJO1
  314.       RE(IJO2,IJO1,1)=RE(IJO2,IJO1,1)+XRET*RLIBRE
  315.       RE(IJO1,IJO2,1)=RE(IJO2,IJO1,1)
  316.  32   CONTINUE
  317.       SEGDES MJONCT
  318.  31   CONTINUE
  319.  30   CONTINUE
  320.       SEGDES MSOLE1
  321. C
  322.  6    CONTINUE
  323.       IINC=KIINC
  324.       SEGSUP IINC
  325.       IIDU=KINCDU
  326.       SEGSUP IIDU
  327.       ICPR=KICPR
  328.       SEGSUP ICPR
  329.       SEGSUP ICONTR
  330.       SEGSUP MVA,MVA1,IPB
  331.       SEGDES DESCR,MELEME,XMATRI,IPT1,MSOLUT
  332.       SEGINI ITRAV
  333.       ITRAV(1)=MELEME
  334.       ITRAV(2)=0
  335.       ITRAV(3)=DESCR
  336.       ITRAV(4)=xMATRI
  337.       ITRAV(5)=NIFOUR
  338.       ITRAV(6)=0
  339.  5000 CONTINUE
  340. C
  341. C   LIAISON POUR DEPLACEMENT IMPOSE
  342. C
  343.       IF(NJODEP.EQ.0) GO TO 6000
  344. C
  345. C  **** INITIALISATION DE LA GEOMETRIE(1 ELEMENT QUI CONTIENT TOUS LES
  346. C  **** POINT-LIAISONS) ET DE LA MATRICE ASSOCIEE XMATRI
  347. C  **** INITIALISATION DE IMATRI ET DE DESCR
  348. C
  349.       NJONC=NJODEP
  350. *      LVAL=NJONC*(NJONC+1)/2
  351.       NLIGRP=NJONC
  352.       NLIGRD=NJONC
  353.       nelrig=1
  354.       rigrel=0
  355.       SEGINI XMATRI
  356. *      DO 40 K=1,LVAL
  357. *      RE(K)=0.D0
  358. *  40  CONTINUE
  359.       SEGINI DESCR
  360.       NELRIG=1
  361. *      SEGINI IMATRI
  362. *      IMATTT(1)=XMATRI
  363. *      SEGDES IMATRI
  364.       SEGACT MSOLUT
  365.       IPT1=MSOLIS(3)
  366.       SEGACT IPT1
  367.       NBSOUS=0
  368.       NBREF=0
  369.       NBNN=NJONC
  370.       NBELEM=1
  371.       SEGINI MELEME
  372.       ITYPEL=27
  373.       DO 41 I=1,NJONC
  374.       NOELEP(I)=I
  375.       NOELED(I)=I
  376.       LISINC(I)='FBET'
  377.       LISDUA(I)='BETA'
  378.       NUM(I,1)=IPT1.NUM(1,ITRDEP(I))
  379.       RE(I,I,1)=1.D0
  380.    41 CONTINUE
  381.       SEGSUP ITRDEP
  382.       SEGDES DESCR,MELEME,XMATRI,MSOLUT,IPT1
  383. C
  384. C   CREATION DE MRIGID
  385. C
  386.  6000 CONTINUE
  387.       NRIGEL=1
  388.       IF(NJOMEC.NE.0.AND.NJODEP.NE.0) NRIGEL=2
  389.       NRIGE=6
  390.       SEGINI MRIGID
  391.       ICHOLE=0
  392.       IMGEO1=0
  393.       IMGEO2=0
  394.       IFORIG=IFOUR
  395.       IF(IRIG.EQ.1) THEN
  396.            MTYMAT='MASSE   '
  397.       ELSE
  398.            MTYMAT='RIGIDITE'
  399.       ENDIF
  400.         I=0
  401.       IF(NJOMEC.NE.0) THEN
  402.         I=I+1
  403.         COERIG(I)=1.D0
  404.         IRIGEL(1,I)=ITRAV(1)
  405.         IRIGEL(2,I)=ITRAV(2)
  406.         IRIGEL(3,I)=ITRAV(3)
  407.         IRIGEL(4,I)=ITRAV(4)
  408.         IRIGEL(5,I)=ITRAV(5)
  409.         IRIGEL(6,I)=ITRAV(6)
  410.         xmatr1=itrav(4)
  411.         segdes xmatr1
  412.         SEGSUP ITRAV
  413.  
  414.       ENDIF
  415.       IF(NJODEP.NE.0) THEN
  416.         I=I+1
  417.         COERIG(I)=1.D0
  418.         IRIGEL(1,I)=MELEME
  419.         IRIGEL(2,I)=0
  420.         IRIGEL(3,I)=DESCR
  421.         IRIGEL(4,I)=xMATRI
  422.         IRIGEL(5,I)=NIFOUR
  423.         IRIGEL(6,I)=0
  424.         segdes xmatri
  425.       ENDIF
  426.  
  427.       SEGDES MRIGID
  428.       IRET=MRIGID
  429.  7000 CONTINUE
  430.       SEGSUP ITRMEC,ITRDEP
  431.  8000 CONTINUE
  432.       RETURN
  433.       END
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  

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