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    CB215821  25/04/23    21:15:41     12247          
  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.       SEGINI XMATRI
  105. *      NLIGRE=NJONC
  106.       SEGINI DESCR
  107.       NELRIG=1
  108. *      SEGINI IMATRI
  109. *      IMATTT(1)=XMATRI
  110. *      SEGDES IMATRI
  111.       SEGACT MSOLUT
  112.       IPT1=MSOLIS(3)
  113.       SEGACT IPT1
  114.       NBSOUS=0
  115.       NBREF=0
  116.       NBNN=NJONC
  117.       NBELEM=1
  118.       SEGINI MELEME
  119.       ITYPEL=27
  120.       MSOLEN=KDEPL
  121. C
  122. C  **** PREPARATION DES OPERATIONS : A IPM ON DONNE LA FORME RECTANGLE
  123. C
  124.       SEGACT MSOLEN
  125.       IPM=ISOLEN(1)
  126.       CALL ETALPR(IPM,KIINC,KICPR,KCONTR)
  127.       ICONTR=KCONTR
  128.       SEGACT ICONTR
  129.       IPR1=MCONTR(/2)
  130.       NNI1=MCONTR(/1)
  131.       SEGINI MVA
  132.       KMVA=MVA
  133.       SEGINI MVA
  134.       KMVB=MVA
  135.       SEGINI IPB
  136.       KIPB=IPB
  137.       IINC=KIINC
  138.       SEGACT IINC
  139.       SEGINI IIDU
  140.       DO 50 I=1,NNI1
  141.       IDDL=CIINC(I)
  142.       DO 51 J=1,LNOMDD
  143.       IF(IDDL.NE.NOMDD(J)) GOTO 51
  144.       CIIDU(I)=NOMDU(J)
  145.       GOTO 50
  146.  51   CONTINUE
  147.       MOTERR=IDDL
  148.       CALL ERREUR(108)
  149. C     ON NE TROUVE PAS IDDL DANS CCHAMP
  150.       GOTO 7000
  151.  50   CONTINUE
  152.       KINCDU=IIDU
  153.       IF(IIMPI.NE.0)WRITE(6,8883)(CIINC(I),CIIDU(I),I=1,NNI1)
  154.  8883 FORMAT(20(1X,A4))
  155. C
  156. C  **** CAS IRIG=1 : TERMES DANS LA MATRICE MASSE : UT.M.U
  157. C
  158.       IF(IRIG.NE.1) GO TO 100
  159.       SEGACT MSOSTU
  160.       MATMAS=ISMASS
  161.       SEGDES MSOSTU
  162.       SEGACT MSOLE1,MSOLEN
  163.       LTAB=ISOLEN(/1)
  164.       DO 9 I=1,NJONC
  165.       MJONCT=MSOLE1.ISOLEN(ITRMEC(I))
  166.       SEGACT MJONCT
  167.       NOELEP(I)=I
  168.       NOELED(I)=I
  169.       IF(MJODDL.EQ.'LX  ') GO TO 16
  170.       LISINC(I)='FBET'
  171.       LISDUA(I)='BETA'
  172.       GO TO 17
  173.  16   LISINC(I)='BETA'
  174.       LISDUA(I)='FBET'
  175.  17   CONTINUE
  176.       SEGDES MJONCT
  177.       NUM(I,1)=IPT1.NUM(1,ITRMEC(I))
  178.  9    CONTINUE
  179. C
  180.       KZERO=0
  181.       DO 10 I=1,NJONC
  182.       IP1=ISOLEN(I)
  183.       CALL MUCPRI(IP1,MATMAS,MUI)
  184.       IF(IERR.NE.0) GOTO 8000
  185.       CALL ETALCH(MUI,KINCDU,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
  186.       IF(IERR.NE.0) GO TO 8000
  187. C
  188.       IF(IIMPI.EQ.0) GOTO 804
  189.       MVA=KMVB
  190.       IPB=KIPB
  191.       SEGACT MVA,IPB
  192.       WRITE(IOIMP,7878)I
  193.  7878 FORMAT('  ************* DANS RGLILI CALCUL DE UJ.M.UI ****',
  194.      1 /,' ========== I=',I4,' ECRITURE DE M.UI SOUS LA FORME VA
  195.      1 PUIS IPB')
  196.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  197.       WRITE(IOIMP,8882)(IPB(KJ2),KJ2=1,IPR1)
  198.  804  CONTINUE
  199. C
  200.       DO 11 J=I,NJONC
  201.       IP2=ISOLEN(J)
  202.       CALL ETALCH(IP2,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
  203.       IF(IERR.NE.0) GOTO 8000
  204. C
  205.       IF(IIMPI.EQ.0) GO TO 803
  206.       MVA=KMVA
  207.       SEGACT MVA
  208.       WRITE(IOIMP,7879)J
  209.  7879 FORMAT(' ========== J=',I4,' ECRITURE DE UJ SOUS LA FORME VA')
  210.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  211.  803  CONTINUE
  212. C
  213. C  **** OPERATION UT . ( M.U )
  214. C
  215.       MVA=KMVA
  216.       MVA1=KMVB
  217.       IPB=KIPB
  218. C      SEGACT MVA,MVA1,IPB
  219.       XRET=0.
  220.       DO 81 J1=1,NPR2
  221.       JJ1=IPB(J1)
  222.       DO 81 I1=1,NNI1
  223.       XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
  224.  81   CONTINUE
  225. C
  226.       IF(IIMPI.EQ.0) GOTO 805
  227.       CALL YTMX(IP1,IP2,MATMAS,WW)
  228.       WRITE(IOIMP,7877)XRET,WW
  229.  7877 FORMAT(' UI.M.UJ = ',E12.5,'   PAR L''OPERATEUR YTMX ON TROUVE '
  230.      1 ,E12.5)
  231.   805 CONTINUE
  232. C
  233. *      K=(J*(J-1)/2)+I
  234.       RE(J,I,1)=XRET
  235.       RE(I,J,1)=XRET
  236.  11   CONTINUE
  237.  10   CONTINUE
  238.       GO TO 6
  239. C
  240. C  ****  CAS IRIG=2 : MATRICE RAIDEUR : LIGNE J COLONNE I: UI ET PJ
  241. C
  242.  100  CONTINUE
  243. C
  244. C  **** PREMIERE BOUCLE SUR LESMJONCT. ON EN SORT MCHPOI QU ON ETALE
  245. C  **** DANS MVA . C EST UI
  246. C
  247.       SEGACT MSOLEN,MSOLE1
  248.       LTAB=ISOLEN(/1)
  249.       DO 30 IJO1=1,NJONC
  250.       MJONCT=MSOLE1.ISOLEN(ITRMEC(IJO1))
  251.       SEGACT MJONCT
  252.       RLIBRE=1.
  253.       IF(MJODDL.EQ.'FLX ') RLIBRE=-1.
  254.       NOELEP(IJO1)=IJO1
  255.       NOELED(IJO1)=IJO1
  256.       IF(MJODDL.EQ.'LX  ') GO TO 18
  257.       LISINC(IJO1)='FBET'
  258.       LISDUA(IJO1)='BETA'
  259.       GO TO 19
  260.  18   LISINC(IJO1)='BETA'
  261.       LISDUA(IJO1)='FBET'
  262.  19   CONTINUE
  263.       NUM(IJO1,1)=IPT1.NUM(1,ITRMEC(IJO1))
  264.       SEGDES MJONCT
  265.       IP1=ISOLEN(ITRMEC(IJO1))
  266.       KZERO=0
  267.       CALL ETALCH(IP1,KIINC,KICPR,KCONTR,KMVA,KZERO,IBID,1)
  268.       IF(IERR.NE.0) GO TO 8000
  269.       IF(IIMPI.EQ.0) GO TO 800
  270.       MVA=KMVA
  271.       SEGACT MVA
  272.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  273.  8880 FORMAT(8(2X,E12.5))
  274.  800  CONTINUE
  275. C
  276. C  **** 2IEME BOUCLE SUR LES MJONCT: ON EN TIRE PJ QU ON ETALE DANS MVB
  277. C
  278.       DO 31 IJO2=IJO1,NJONC
  279.       MJONCT=MSOLE1.ISOLEN(ITRMEC(IJO2))
  280.       SEGACT MJONCT
  281.       NST=ISTRJO(/1)
  282.       DO 32 IS=1,NST
  283.       IF(ISTRJO(IS).NE.MSOSTU) GO TO 32
  284.       IPP2=IPCHJO(IS)
  285.       CALL ETALCH(IPP2,KIINC,KICPR,KCONTR,KMVB,KIPB,NPR2,1)
  286.       IF(IERR.NE.0) GO TO 8000
  287.       IF(IIMPI.EQ.0) GO TO 801
  288.       MVA=KMVB
  289.       IPB=KIPB
  290.       SEGACT MVA,IPB
  291.       WRITE(IOIMP,8880)((VA(KJ1,KJ2),KJ1=1,NNI1),KJ2=1,IPR1)
  292.       WRITE(IOIMP,8882)(IPB(KJ2),KJ2=1,IPR1)
  293.  8882 FORMAT( 10I6)
  294.  801  CONTINUE
  295. C
  296. C  **** OPERATION VA*VB
  297. C
  298.       MVA=KMVA
  299.       MVA1=KMVB
  300.       IPB=KIPB
  301. C      SEGACT MVA,MVA1,IPB
  302. C
  303.       XRET=0.
  304.       DO 80 J1=1,NPR2
  305.       JJ1=IPB(J1)
  306.       DO 80 I1=1,NNI1
  307.       XRET=XRET+VA(I1,JJ1)*MVA1.VA(I1,JJ1)
  308.  80   CONTINUE
  309. C
  310. *      K=(IJO2*(IJO2-1)/2)+IJO1
  311.       RE(IJO2,IJO1,1)=RE(IJO2,IJO1,1)+XRET*RLIBRE
  312.       RE(IJO1,IJO2,1)=RE(IJO2,IJO1,1)
  313.  32   CONTINUE
  314.       SEGDES MJONCT
  315.  31   CONTINUE
  316.  30   CONTINUE
  317.       SEGDES MSOLE1
  318. C
  319.  6    CONTINUE
  320.       IINC=KIINC
  321.       SEGSUP IINC
  322.       IIDU=KINCDU
  323.       SEGSUP IIDU
  324.       ICPR=KICPR
  325.       SEGSUP ICPR
  326.       SEGSUP ICONTR
  327.       SEGSUP MVA,MVA1,IPB
  328.       SEGDES DESCR,MELEME,XMATRI,IPT1,MSOLUT
  329.       SEGINI ITRAV
  330.       ITRAV(1)=MELEME
  331.       ITRAV(2)=0
  332.       ITRAV(3)=DESCR
  333.       ITRAV(4)=xMATRI
  334.       ITRAV(5)=NIFOUR
  335.       ITRAV(6)=0
  336.  5000 CONTINUE
  337. C
  338. C   LIAISON POUR DEPLACEMENT IMPOSE
  339. C
  340.       IF(NJODEP.EQ.0) GO TO 6000
  341. C
  342. C  **** INITIALISATION DE LA GEOMETRIE(1 ELEMENT QUI CONTIENT TOUS LES
  343. C  **** POINT-LIAISONS) ET DE LA MATRICE ASSOCIEE XMATRI
  344. C  **** INITIALISATION DE IMATRI ET DE DESCR
  345. C
  346.       NJONC=NJODEP
  347. *      LVAL=NJONC*(NJONC+1)/2
  348.       NLIGRP=NJONC
  349.       NLIGRD=NJONC
  350.       nelrig=1
  351.       SEGINI XMATRI
  352. *      DO 40 K=1,LVAL
  353. *      RE(K)=0.D0
  354. *  40  CONTINUE
  355.       SEGINI DESCR
  356.       NELRIG=1
  357. *      SEGINI IMATRI
  358. *      IMATTT(1)=XMATRI
  359. *      SEGDES IMATRI
  360.       SEGACT MSOLUT
  361.       IPT1=MSOLIS(3)
  362.       SEGACT IPT1
  363.       NBSOUS=0
  364.       NBREF=0
  365.       NBNN=NJONC
  366.       NBELEM=1
  367.       SEGINI MELEME
  368.       ITYPEL=27
  369.       DO 41 I=1,NJONC
  370.       NOELEP(I)=I
  371.       NOELED(I)=I
  372.       LISINC(I)='FBET'
  373.       LISDUA(I)='BETA'
  374.       NUM(I,1)=IPT1.NUM(1,ITRDEP(I))
  375.       RE(I,I,1)=1.D0
  376.    41 CONTINUE
  377.       SEGSUP ITRDEP
  378.       SEGDES DESCR,MELEME,XMATRI,MSOLUT,IPT1
  379. C
  380. C   CREATION DE MRIGID
  381. C
  382.  6000 CONTINUE
  383.       NRIGEL=1
  384.       IF(NJOMEC.NE.0.AND.NJODEP.NE.0) NRIGEL=2
  385.       NRIGE=6
  386.       SEGINI MRIGID
  387.       ICHOLE=0
  388.       IMGEO1=0
  389.       IMGEO2=0
  390.       IFORIG=IFOUR
  391.       IF(IRIG.EQ.1) THEN
  392.            MTYMAT='MASSE   '
  393.       ELSE
  394.            MTYMAT='RIGIDITE'
  395.       ENDIF
  396.         I=0
  397.       IF(NJOMEC.NE.0) THEN
  398.         I=I+1
  399.         COERIG(I)=1.D0
  400.         IRIGEL(1,I)=ITRAV(1)
  401.         IRIGEL(2,I)=ITRAV(2)
  402.         IRIGEL(3,I)=ITRAV(3)
  403.         IRIGEL(4,I)=ITRAV(4)
  404.         IRIGEL(5,I)=ITRAV(5)
  405.         IRIGEL(6,I)=ITRAV(6)
  406.         xmatr1=itrav(4)
  407.         segdes xmatr1
  408.         SEGSUP ITRAV
  409.  
  410.       ENDIF
  411.       IF(NJODEP.NE.0) THEN
  412.         I=I+1
  413.         COERIG(I)=1.D0
  414.         IRIGEL(1,I)=MELEME
  415.         IRIGEL(2,I)=0
  416.         IRIGEL(3,I)=DESCR
  417.         IRIGEL(4,I)=xMATRI
  418.         IRIGEL(5,I)=NIFOUR
  419.         IRIGEL(6,I)=0
  420.         segdes xmatri
  421.       ENDIF
  422.  
  423.       SEGDES MRIGID
  424.       IRET=MRIGID
  425.  7000 CONTINUE
  426.       SEGSUP ITRMEC,ITRDEP
  427.  8000 CONTINUE
  428.       RETURN
  429.       END
  430.  
  431.  
  432.  
  433.  
  434.  
  435.  
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  

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