Télécharger la plaquette Cast3M


fr en

Télécharger rela1.eso

Retour à la liste

Numérotation des lignes : 

rela1

  1. C RELA1     SOURCE    PV090527  26/04/30    21:16:06     12529          
  2.       SUBROUTINE RELA1
  3. C
  4. C     RELAZIONE LINEARE TRA DDL
  5. C
  6. C     ICONR  NUMERO OGGETTI MELEME DELLA RELAZIONE
  7. C     ITYESR(NBSOUS) LISTA TIPI ELEMENTI CONTENUTI IN MELEME-N
  8. C     MUNESR(NBSOUS)  NUMERO ELEMENTI IN OGNI SOTTOSTRUTTURA DI MELEME-N
  9. C     LNODSR(NNR) LISTA NODI MELEME-N
  10. C     IPOR1(N)  PUNTATORE SU MWREL1
  11. C     IPOR2(N)  PUNTATORE SU MWREL2
  12. C     IPOR3(N)  PUNTATORE SU MWREL3
  13. C     COEFR(N)  COEFFICIENTI RELAZIONE
  14. C     INCREL(N) IDENTIFICATORE NOME DDL
  15. C
  16.       IMPLICIT INTEGER(I-N)
  17.       IMPLICIT REAL*8(A-H,O-Z)
  18.  
  19. -INC SMELEME
  20. -INC SMCOORD
  21. -INC SMRIGID
  22. -INC TMTRAV
  23. -INC SMCHPOI
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC CCREEL
  28. -INC CCGEOME
  29. -INC CCHAMP
  30.  
  31.       SEGMENT /MWGGM1/(IPORE1(0))
  32.       SEGMENT /MWGGM2/(IPORE2(0))
  33.       SEGMENT /MWGGM3/(IPORE3(0))
  34.       SEGMENT /MWGGM4/(INCREL(0))
  35.       SEGMENT /MWGGM5/(COEFR(0)*D)
  36.       SEGMENT /MWREL1/(ITYESR(0)),IEL11.MWREL1,
  37.      +     IEL21.MWREL1,iel01.MWREL1
  38.       SEGMENT /MWREL2/(MUNESR(0)),IEL12.MWREL2,
  39.      +     IEL22.MWREL2,iel02.MWREL2
  40.       SEGMENT /MWREL3/(LNODSR(0)),IEL13.MWREL3,
  41.      +     IEL23.MWREL3
  42.       CHARACTER*4 MOTPV(3)
  43.       CHARACTER*4 MOCORI(7)
  44.       CHARACTER*4 MOTPM(2)
  45.       CHARACTER*4 MOTDDL(3)
  46.       CHARACTER*4 MOTBLO(3)
  47.       CHARACTER*4 MODEPL(8)
  48.       CHARACTER*4 MOROTA(5)
  49.       CHARACTER*4 MODUAL(1)
  50.       CHARACTER*8 MILMOT
  51.       DIMENSION XNOR(3)
  52.       DATA MOTPV /'MINI','MAXI','FROT'/
  53.       DATA MOTPM /'+   ','-   '/
  54.       DATA MOCORI/'CORI','ENSE','ACCR','GLIS','BARY','MILI','TUYA'/
  55. C
  56.       DATA MOTBLO/'DEPL','ROTA','DIRE'/
  57.       DATA MODEPL/'UX  ','UY  ','UZ  ','UR  ','UZ  ','UT  ',
  58.      &     'ALFA','BETA'/
  59.       DATA MOROTA/'RX  ','RY  ','RZ  ','RT  ','RS  '/
  60.       DATA MODUAL/'DUAL'/
  61. c
  62.       iel01=0
  63.       iel02=0
  64. C
  65. C     EST-CE UNE RELATION DE CORPS RIGIDE ?
  66. C
  67.  
  68.       CALL LIRMOT(MOCORI,7,ICORI,0)
  69. *      write(ioimp,*) 'rela1, icori=',icori
  70.       IF (ICORI.NE.0) THEN
  71. c     BARY
  72.          if (icori.eq.5) then
  73.             call relaba
  74. c     MILI
  75.          ELSE IF (ICORI.EQ.6) THEN
  76.             CALL LIROBJ('LISTMOTS',IP0,0,IRETOU)
  77.             IF (IERR.NE.0) RETURN
  78.             CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  79.             IF (IERR.NE.0) RETURN
  80.             CALL RELAMI(IP0,IPT1,IPRIG)
  81.             CALL ECROBJ('RIGIDITE',IPRIG)
  82. c     TUYA
  83.          elseif(icori.eq.7) then
  84.             call reltuy
  85. c     CORI, ENSE, ACCRO, GLIS
  86.          else
  87.             CALL RELA2(MOCORI(ICORI))
  88.          endif
  89.          RETURN
  90.       ENDIF
  91. C
  92. C     EST-CE UNE CONDITION UNILATERALE ?
  93. C
  94.       NILATE=0
  95.       CALL LIRMOT (MOTPV,3,IPO,0)
  96.       IF(IPO.EQ.1) NILATE=-1
  97.       IF(IPO.EQ.2) NILATE=+1
  98.       IF(IPO.EQ.3) NILATE=+2
  99. C
  100. C     INITIALISATIONS
  101. C
  102.       COEX=1.D0
  103. C
  104. C     Deformations planes ou contraintes planes ou defo. plane gene :
  105.       IF (IFOUR.EQ.-1.OR.IFOUR.EQ.-2.OR.IFOUR.EQ.-3) THEN
  106.          LDEPL=2
  107.          IADEPL=0
  108.          LROTA=1
  109.          IAROTA=2
  110. C     Axisymetrique :
  111.       ELSE IF (IFOUR.EQ.0) THEN
  112.          LDEPL=2
  113.          IADEPL=3
  114.          LROTA=1
  115.          IAROTA=3
  116. C     Fourier :
  117.       ELSE IF (IFOUR.EQ.1) THEN
  118.          LDEPL=3
  119.          IADEPL=3
  120.          LROTA=2
  121.          IAROTA=2
  122. C     Tridimensionnel :
  123.       ELSE IF (IFOUR.EQ.2) THEN
  124.          LDEPL=3
  125.          IADEPL=0
  126.          LROTA=3
  127.          IAROTA=0
  128. C     Massif 1D (IDIM=1) :
  129.       ELSE IF (IFOUR.GE.3.AND.IFOUR.LE.15) THEN
  130.          LDEPL=1
  131.          IADEPL=0
  132.          IF (IFOUR.GE.12) IADEPL=3
  133.          LROTA=0
  134.          IAROTA=0
  135. C     Autres cas :
  136.       ELSE
  137.          LDEPL=0
  138.          IADEPL=0
  139.          LROTA=0
  140.          IAROTA=0
  141.       ENDIF
  142. C
  143.       SEGINI MWGGM1
  144.       SEGINI MWGGM2
  145.       SEGINI MWGGM3
  146.       SEGINI MWGGM4
  147.       SEGINI MWGGM5
  148. *
  149. *     LECTURE EVENTUELLE D'UN MODELLE
  150. *
  151.  
  152.       CALL LIROBJ('MMODEL',IPOMOD,0,IREMOD)
  153.       IF(IREMOD.NE.0) THEN
  154.          CALL RELMOD(IPOMOD)
  155.          RETURN
  156.       ENDIF
  157. *
  158. *     LECTURE EVENTUELLE D'UN CHPOINT
  159. *
  160.       CALL LIROBJ('CHPOINT',IPOCHP,0,IRECHP)
  161.       IF(IRECHP.NE.0) THEN
  162.         CALL ACTOBJ('CHPOINT',IPOCHP,1)
  163. *  lecture eventuelle mot cle DUAL
  164.          IRECHD=0
  165.          CALL LIRMOT (MODUAL,1,IRECHD,0)
  166.          IF(IRECHD.EQ.1) GOTO 500
  167. *
  168. *     ON MET LE CHPOINT SOUS FORME DE TABLEAU DE TRAVAIL
  169. *
  170.          CALL TRACHP(IPOCHP,MTRAV)
  171.          SEGACT MTRAV
  172.          DO 1990 I=1,IBIN(/1)
  173.             DO 19901 J=1,IBIN(/2)
  174.                IF(IBIN(I,J).EQ.0) GO TO 19901
  175.                CALL PLACE(NOMDD,LNOMDD,IPO,INCO(I))
  176.                if (ipo.eq.0) then
  177.                  CALL PLACE(NOMDU,LNOMDU,IPO,INCO(I))
  178.                  ipo = -ipo
  179.                endif
  180.                IF(IPO.EQ.0) THEN
  181.                   moterr(1:4)=inco(i)
  182.                   SEGSUP MTRAV
  183.                   call erreur(108)
  184.                   GO TO 559
  185.                ENDIF
  186.                SEGINI MWREL1
  187.                SEGINI MWREL2
  188.                SEGINI MWREL3
  189.                IPORE1(**)=MWREL1
  190.                IPORE2(**)=MWREL2
  191.                IPORE3(**)=MWREL3
  192.                COEFR(**)=BB(I,J)
  193.                INCREL(**)=IPO
  194.                ITYESR(**)=1
  195.                MUNESR(**)=1
  196.                LNODSR(**)=IGEO(J)
  197. 19901       CONTINUE
  198.  1990    CONTINUE
  199.          SEGSUP MTRAV
  200.          GO TO 300
  201.       ENDIF
  202.  200  CONTINUE
  203. C
  204. C     LETTURA OPERANDI
  205. C
  206.       SEGINI MWREL1
  207.       SEGINI MWREL2
  208.       SEGINI MWREL3
  209.       IPORE1(**)=MWREL1
  210.       IPORE2(**)=MWREL2
  211.       IPORE3(**)=MWREL3
  212.  1320 CONTINUE
  213.       CALL LIRREE(XR,0,IRETOF)
  214.       IF(IRETOF.EQ.0) THEN
  215.          CALL LIRENT(IR,0,IRETOI)
  216.          XR=1.D0
  217.          IF(IRETOI.NE.0) XR=DBLE(IR)
  218.       ENDIF
  219.       CALL LIRMOT(NOMDD,LNOMDD,IPO,0)
  220.       IF(IPO.NE.0) THEN
  221.          COEFR(**)=XR*COEX
  222.          INCREL(**)=IPO
  223.       ELSE
  224. *
  225. *     ON REGARDE SI IL Y A DEPL OU ROTA SUIVI DE DIRECTION
  226. *
  227. C     En DIMENSION 1, le mot-cle 'DIRE' est interdit.
  228.          IF (IDIM.EQ.1) THEN
  229.             INTERR(1)=IDIM
  230.             MOTERR(1:4)=MOTBLO(3)
  231.             CALL ERREUR(971)
  232.             GOTO 559
  233.          ENDIF
  234.          CALL LIRMOT(MOTBLO,2,IMOT,1)
  235.          IF (IMOT.EQ.0) GOTO 559
  236.          IF (IMOT.EQ.1) THEN
  237.             IBDDL=LDEPL
  238.             DO 4481 IA=1,IBDDL
  239.                MOTDDL(IA)=MODEPL(IADEPL+IA)
  240.  4481       CONTINUE
  241.          ENDIF
  242.          IF (IMOT.EQ.2) THEN
  243.             IBDDL=LROTA
  244.             DO 4482 IA=1,IBDDL
  245.                MOTDDL(IA)=MOROTA(IAROTA+IA)
  246.  4482       CONTINUE
  247.          ENDIF
  248.          CALL LIRMOT(MOTBLO(3),1,IMOT,1)
  249.          IF(IMOT.EQ.0) GO TO 559
  250.          CALL LIROBJ('POINT',KPOINT,1,IRETOU)
  251.          IF(IRETOU.EQ.0) GO TO 559
  252.          YL=0.D0
  253.          XPREC=SQRT(XPETIT/XZPREC)
  254.          segact mcoord
  255.          DO 4484 IA=1,IDIM
  256.             XVAL    =XCOOR((KPOINT-1)*(IDIM+1)+IA)
  257.             XNOR(IA)=XVAL
  258.             IF(ABS(XVAL) .GT. XPREC)THEN
  259.               YL=YL+XVAL**2
  260.             ENDIF
  261.  4484    CONTINUE
  262.          IF (YL .EQ. 0.D0) THEN
  263.             CALL ERREUR(239)
  264.             GOTO 559
  265.          ENDIF
  266.          YL=1.D0/SQRT(YL)
  267.          DO 4485 IA=1,IDIM
  268.             XNOR(IA)=XNOR(IA)*YL
  269.  4485    CONTINUE
  270. *
  271. *     ON LIT LE MAILLAGE
  272. *
  273.          CALL LIROBJ('POINT   ',MILPOI,0,IRETOU)
  274.          IF(IRETOU.NE.0) THEN
  275.             MILMOT='POINT   '
  276.          ELSE
  277.             CALL LIROBJ('MAILLAGE',MILPOI,1,IRETOU)
  278.             IF(IRETOU.EQ.0)  GO TO 559
  279.             MILMOT='MAILLAGE'
  280.          ENDIF
  281. *
  282. *     PUIS ON REMET DES OBJETS DANS LA PILE
  283. *
  284.          DO 4477 IB=1,IBDDL
  285.             IF(IB.GE.2.AND.COEX.EQ. 1.D0) CALL ECRCHA(MOTPM(1))
  286.             IF(IB.GE.2.AND.COEX.EQ.-1.D0) CALL ECRCHA(MOTPM(2))
  287.             CALL ECROBJ(MILMOT,MILPOI)
  288.             CALL ECRCHA(MOTDDL(IB))
  289.             IF(IBDDL.EQ.1) THEN
  290.                XRCOO=XR
  291.             ELSE
  292.                XRCOO=XR*XNOR(IB)
  293.             ENDIF
  294.             CALL ECRREE(XRCOO)
  295.  4477    CONTINUE
  296.          GO TO 1320
  297.       ENDIF
  298. C
  299.       CALL LIROBJ('POINT   ',KPOINT,0,IRETOU)
  300.       IF(IRETOU.NE.0) GO TO 110
  301.       CALL LIROBJ('MAILLAGE',KOBJET,1,IRETOU)
  302.       IF(IRETOU.EQ.0)  GO TO 559
  303.       MELEME=KOBJET
  304.       SEGACT MELEME
  305.       NBSOUS=LISOUS(/1)
  306.       IF(NBSOUS.EQ.0) GO TO 120
  307. C     OBJET COMPLEXE
  308.       NNR=1
  309.       DO 130 IS=1,NBSOUS
  310.          IPT1=LISOUS(IS)
  311.          SEGACT IPT1
  312.          ITYESR(**)=IPT1.ITYPEL
  313.          NBNN      =IPT1.NUM(/1)
  314.          NBELEM    =IPT1.NUM(/2)
  315.          MUNESR(**)=IPT1.NUM(/2)
  316.          IF(NNR.EQ.1)LNODSR(**)=IPT1.NUM(1,1)
  317.          DO 140  I1=1,NBELEM
  318.             DO 1401  I2=1,NBNN
  319.                DO 150  I3=1,NNR
  320.                   IF(LNODSR(I3).EQ.IPT1.NUM(I2,I1)) GO TO 1401
  321.  150           CONTINUE
  322.                NNR=NNR+1
  323.                LNODSR(**)=IPT1.NUM(I2,I1)
  324.  1401       CONTINUE
  325.  140     CONTINUE
  326.          SEGDES IPT1
  327.  130  CONTINUE
  328.       SEGDES MWREL1
  329.       SEGDES MWREL2
  330.       SEGDES MWREL3
  331.       SEGDES MELEME
  332.       GO TO 160
  333. C
  334. C     OBJET SIMPLE
  335. C
  336.  120  CONTINUE
  337.       ITYESR(**)=ITYPEL
  338.       NBNN      =NUM(/1)
  339.       NBELEM    =NUM(/2)
  340.       MUNESR(**)=NUM(/2)
  341.       NNR=0
  342.       DO 170  I1=1,NBELEM
  343.          DO 1701  I2=1,NBNN
  344.             DO 180  I3=1,NNR
  345.                IF(LNODSR(I3).EQ.NUM(I2,I1)) GO TO 1701
  346.  180        CONTINUE
  347.             NNR=NNR+1
  348.             LNODSR(**)=NUM(I2,I1)
  349.  1701    CONTINUE
  350.  170  CONTINUE
  351.       SEGDES MWREL1
  352.       SEGDES MWREL2
  353.       SEGDES MWREL3
  354.       SEGDES MELEME
  355.       GO TO 160
  356.  110  CONTINUE
  357. C
  358. C     OBJET POINT
  359. C
  360.       ITYESR(**)=1
  361.       MUNESR(**)=1
  362.       LNODSR(**)=KPOINT
  363.       SEGDES MWREL1
  364.       SEGDES MWREL2
  365.       SEGDES MWREL3
  366. C     FINE OPERANDO RELAZIONE
  367.  160  CONTINUE
  368.       ICONR=IPORE1(/1)+1
  369. C     LETTURA + O -
  370.       IF(ICONR.EQ.2) CALL LIRMOT(MOTPM,2,IPO,0)
  371.       IF (IPO.EQ.0)  GO TO 300
  372. *     LIRMOT(MOTPM,2,IPO,1) goto 559
  373.       IF(ICONR.GT.2) CALL LIRMOT(MOTPM,2,IPO,0)
  374.       IF (IPO.EQ.0)  GO TO 300
  375.       COEX=1.D0
  376.       IF (IPO.EQ.2) COEX=-1.D0
  377. C     SI CERCA DI LEGGERE UN NUOVO OPERANDO DELLA RELAZIONE
  378.       GO TO  200
  379. C
  380. C     VERIFICA CONGRUENZA OPERANDI
  381. C
  382.  300  CONTINUE
  383. C
  384.       ICONR=IPORE1(/1)
  385.       IEL11=IPORE1(1)
  386.       IEL12=IPORE2(1)
  387.       IEL13=IPORE3(1)
  388. *     on autorise maintenant le point unique qui va etre applique sur
  389. *     chaque relation
  390. *     old      ityes=0
  391. *     old      munes=0
  392.       nsor=0
  393.       nnr=0
  394.       do 305 io=1,iconr
  395. *     write(ioimp,*) 'io=',io
  396.          iel11=ipore1(io)
  397.          iel12=ipore2(io)
  398.          iel13=ipore3(io)
  399.          segact iel11,iel12,iel13
  400.          nsor1=iel11.ityesr(/1)
  401.          nsor=max(nsor,nsor1)
  402.          NNR1=IEL13.LNODSR(/1)
  403.          nnr=max(nnr,nnr1)
  404. *     old         do 315 i1=1,nsor1
  405.          if (io.eq.1) then
  406.             segini,iel01=iel11
  407.             segini,iel02=iel12
  408.          else
  409.             do 315 i1=1,nsor1
  410.                ityes=iel01.ityesr(i1)
  411.                iel01.ityesr(i1)=max(iel11.ityesr(i1),ityes)
  412. *     write(ioimp,*) 'i1=',i1,' ityes=',ityes
  413. *     $              ,' iel11.ityesr(i1)',iel11.ityesr(i1)
  414.                munes=iel02.munesr(i1)
  415.                iel02.munesr(i1)=max(iel12.munesr(i1),munes)
  416. *     write(ioimp,*) 'i1=',i1,' munes=',munes
  417. *     $              ,' iel12.munesr(i1)',iel12.munesr(i1)
  418.  315        continue
  419.          endif
  420.  305  continue
  421.       DO 310 IO=1,ICONR
  422. *     write(ioimp,*) 'io=',io
  423.          IEL21=IPORE1(IO)
  424.          IEL22=IPORE2(IO)
  425.          IEL23=IPORE3(IO)
  426.          NSOR2=IEL21.ITYESR(/1)
  427. *     write(ioimp,*) 'nsor,nsor2=',nsor,nsor2
  428.          IF(NSOR.NE.NSOR2.and.nsor2.ne.1) GO TO 556
  429.          DO 320 I2=1,NSOR2
  430.             ityes=iel01.ityesr(i2)
  431.             munes=iel02.munesr(i2)
  432. *     write(ioimp,*) 'i2=',i2,' ityes=',ityes,'munes=',munes
  433. *     write(ioimp,*) 'iel21.ityesr=',iel21.ityesr(i2)
  434. *     $           ,' IEL22.MUNESR(I2)=',IEL22.MUNESR(I2)
  435.             if (iel21.ityesr(i2).eq.1.and.iel22.munesr(i2).eq.1.and.
  436.      >           nsor2.eq.1) goto 320
  437.             IF(IEL21.ITYESR(I2).NE.ityes) GO TO 556
  438.             IF(IEL22.MUNESR(I2).NE.munes) GO TO 556
  439.  320     CONTINUE
  440.          NNR2=IEL23.LNODSR(/1)
  441. *     write(ioimp,*) 'nnr,nnr2=',nnr,nnr2
  442.          IF(NNR2.NE.NNR.and.nnr2.ne.1) GO TO 556
  443.  310  CONTINUE
  444.       if (iel01.ne.0) SEGSUP,IEL01
  445.       if (iel02.ne.0) SEGSUP,IEL02
  446.       NBRELA=NNR
  447. C     OPERANDI  CONGRUENTI  FINE VERIFICA
  448. C
  449. C     CARICAMENTO MATRICE  RIGIDEZZA
  450. C
  451.       NRIGEL=1
  452.       SEGINI MRIGID
  453.       ICHOLE=0
  454.       IMGEO1=0
  455.       IMGEO2=0
  456.       ISUPEQ=0
  457.       IFORIG=IFOUR
  458.       COERIG(1)=1.D0
  459.       MTYMAT='RIGIDITE'
  460.       KRIGI=MRIGID
  461. C
  462. C     ON INITIALISE LE SEGMENT MELEME ASSOCIE AUX BLOCAGES
  463. C
  464.       SEGACT MCOORD*MOD
  465.       NBPTSO=nbpts
  466. *      write(ioimp,*) 'nbptso=',nbptso
  467.       NBPTS=NBPTSO+NBRELA
  468.       SEGADJ MCOORD
  469.       NBSOUS=0
  470.       NBREF=0
  471.       NBNN=1+ICONR
  472.       NBELEM=NBRELA
  473.       SEGINI IPT2
  474.       IRIGEL(1,1)=IPT2
  475.       IPT2.ITYPEL=22
  476. C     SI CREANO UNO PUNTO PER OGNI RELAZIONE
  477.       DO 400 I4=1,NBRELA
  478.          IPT2.ICOLOR(I4)=IDCOUL
  479.          IPTS=NBPTSO+I4
  480.          JPTS=(IPTS-1)*(IDIM+1)
  481.          DO 410 iidim=1,idim+1
  482.             XCOOR(JPTS+iidim)=0.D0
  483.  410     CONTINUE
  484. C     PUNTI ASSOCIATI AI MOLTIPLICATORI
  485.          IPT2.NUM(1,I4)=IPTS
  486.  400  CONTINUE
  487. C     CARICAMENTO NODI PSEUDO-ELEMENTI
  488.       DO 420 I8=1,ICONR
  489.          MWREL3=IPORE3(I8)
  490.          I10=I8+1
  491.          SEGACT MWREL3
  492.          LNOMAX=LNODSR(/1)
  493.          DO 430 I9=1,NBRELA
  494.             NN=LNODSR(min(I9,lnomax))
  495.             NPN=(NN-1)*(IDIM+1)
  496.             IPT2.NUM(I10,I9)=NN
  497.             NPL1=(IPT2.NUM(1,I9)-1)*(IDIM+1)
  498.             do 4301 iidim=1,idim+1
  499.                XCOOR(NPL1+iidim)=XCOOR(NPL1+iidim)+XCOOR(NPN+iidim)
  500.  4301       continue
  501.  430     CONTINUE
  502.          SEGDES MWREL3
  503.  420  CONTINUE
  504. C
  505. C     COORDINATE DEI BARICENTRI ASSOCIATI ALLE RELAZIONI
  506. C
  507. *      write(ioimp,*) 'iconr,nbrela,idim=',iconr,nbrela,idim
  508.       DO 425 I4=1,NBRELA
  509.          NPL1=(IPT2.NUM(1,I4)-1)*(IDIM+1)
  510.          do 4251 iidim=1,idim+1
  511.             XCOOR(NPL1+iidim)=XCOOR(NPL1+iidim)/ICONR
  512.  4251    continue
  513.  425  CONTINUE
  514.  
  515.       SEGDES IPT2
  516.       IRIGEL(2,1)=0
  517.       IRIGEL(5,1)=NIFOUR
  518.       IRIGEL(6,1)=NILATE
  519.       NLIGRP=ICONR+1
  520.       NLIGRD=NLIGRP
  521.       SEGINI DESCR
  522.       IRIGEL(3,1)=DESCR
  523.       LISINC(1)='LX'
  524.       LISDUA(1)='FLX'
  525.       NOELEP(1)=1
  526.       NOELED(1)=1
  527.       DO 700 I1=1,ICONR
  528.          I2=I1+1
  529.          I3=ABS(INCREL(I1))
  530.          LISINC(I2)=NOMDD(I3)
  531.          LISDUA(I2)=NOMDU(I3)
  532.          NOELEP(I2)=I2
  533.          NOELED(I2)=I2
  534.  700  CONTINUE
  535.       SEGDES DESCR
  536.       NELRIG=NBRELA
  537.       rigrel=0
  538.       SEGINI xMATRI
  539.       IRIGEL(4,1)=xMATRI
  540. *     LVAL=(NBNN*NBNN+NBNN)/2
  541.       NLIGRP=NBNN
  542.       NLIGRD=NBNN
  543. *     SEGINI XMATRI
  544.       DO 740 I6=1,NELRIG
  545. *     IMATTT(I1)=XMATRI
  546. *     740   CONTINUE
  547.          RE(1,1,i6)= 0.D0
  548.          I3=3
  549.          DO 760 I1=2,NBNN
  550.             I4=I1-1
  551.             I2=1
  552.             RE(I1,I2,i6)=COEFR(I4)
  553.             RE(I2,I1,i6)=COEFR(I4)
  554.  760     CONTINUE
  555.  740  continue
  556.       SEGDES XMATRI
  557. *     SEGDES IMATRI
  558.       call relasi(mrigid)
  559.       SEGDES MRIGID
  560.       CALL ECROBJ('RIGIDITE',KRIGI)
  561.  559  CONTINUE
  562.       ICONR=IPORE1(/1)
  563.       DO 558 I1=1,ICONR
  564.          MWREL1=IPORE1(I1)
  565.          MWREL2=IPORE2(I1)
  566.          MWREL3=IPORE3(I1)
  567.          SEGSUP MWREL1
  568.          SEGSUP MWREL2
  569.          SEGSUP MWREL3
  570.  558  CONTINUE
  571.       SEGSUP MWGGM1
  572.       SEGSUP MWGGM2
  573.       SEGSUP MWGGM3
  574.       SEGSUP MWGGM4
  575.       SEGSUP MWGGM5
  576.       RETURN
  577.  556  CONTINUE
  578. C     SEGDES IEL11,IEL12,IEL13,IEL21,IEL22,IEL23
  579.       CALL ERREUR(324)
  580.       GO TO 559
  581. *
  582. *  on arrive en 500 avec la syntaxe chp1 DUAL chp2
  583. *
  584.  500  continue
  585.       CALL LIROBJ('CHPOINT',IPOCHD,1,IRECHD)
  586.       if (ierr.ne.0) return
  587. * ipochp est le chpoin de la relation
  588. * ipochd est le chpoin du vecteur de controle
  589. * decompte des dimensions
  590.       nbsous=0
  591.       nbref=0
  592.       nbelem=1
  593.       mchpoi=ipochp
  594.       segact mchpoi
  595. *  reserver la place pour le lx
  596.       nligrp=1
  597.       nbnp=0
  598.       do ims=1,ipchp(/1)
  599.        msoupo=ipchp(ims)
  600.        segact msoupo
  601.        mpoval=ipoval
  602.        segact mpoval
  603.        nligrp=nligrp+vpocha(/1)*vpocha(/2)
  604.        meleme=igeoc
  605.        segact meleme
  606.        nbnp=nbnp+num(/2)
  607.       enddo
  608. *     write(6,*) ' nligrp nbelep ',nligrp,nbelep
  609.       mchpoi=ipochd
  610.       segact mchpoi
  611.       nbnd=0
  612.       xnormd = 0.d0
  613. *  reserver la place pour le flx
  614.       nligrd=1
  615.       do ims=1,ipchp(/1)
  616.        msoupo=ipchp(ims)
  617.        segact msoupo
  618.        mpoval=ipoval
  619.        segact mpoval
  620.        nligrd=nligrd+vpocha(/1)*vpocha(/2)
  621.        do j=1,vpocha(/2)
  622.        do i=1,vpocha(/1)
  623.         xnormd=max(xnormd,abs(vpocha(i,j)))
  624.        enddo
  625.        enddo
  626.        if (xnormd.lt.1d-5.or.xnormd.gt.1E5) then
  627.          reaerr(1)=xnormd
  628.          call erreur(1118)
  629.          return
  630.        endif
  631.        meleme=igeoc
  632.        segact meleme
  633.        nbnd=nbnd+num(/2)
  634.       enddo
  635. *     write(6,*) ' nligrd nbeled ',nligrd,nbeled
  636. * creation rigidite
  637.       nligrp=nligrp+nligrd-1
  638.       nligrd=nligrp
  639.       segini descr
  640.       nbnn=nbnp+1
  641. *  maillage primal uniquement
  642.       nbnn=nbnd+1
  643. *  maillage dual   uniquement
  644.       nbnn=nbnp+nbnd+1
  645.       nbref=0
  646.       segini meleme
  647.       itypel=22
  648.       nelrig=1
  649.       rigrel=0
  650.       segini xmatri
  651.       symre=2
  652.       nrigel=1
  653.       segini mrigid
  654.       ICHOLE=0
  655.       IMGEO1=0
  656.       IMGEO2=0
  657.       ISUPEQ=0
  658.       IFORIG=IFOUR
  659.       COERIG(1)=1.D0
  660.       MTYMAT='RIGIDITE'
  661.       irigel(1,1)=meleme
  662.       irigel(3,1)=descr
  663.       irigel(4,1)=xmatri
  664.       IRIGEL(5,1)=NIFOUR
  665.       irigel(6,1)=nilate
  666.       irigel(7,1)=2
  667. *  remplissage maillage descripteur et valeur
  668. *  le premier noeud sera fait a la fin. C'est le multiplicateur de lagrange
  669.       iel=1
  670.       ire=1
  671.       ire=1
  672.       nbnp=1
  673.       nbnd=1
  674.       mchpoi=ipochp
  675.       do ims=1,ipchp(/1)
  676.        msoupo=ipchp(ims)
  677.        segact msoupo
  678.        ipt1=igeoc
  679.        segact ipt1
  680.        mpoval=ipoval
  681.        segact mpoval
  682.        do i=1,ipt1.num(/2)
  683.         iel=iel+1
  684.         num(iel,1)=ipt1.num(1,i)
  685.         nbnp=nbnp+1
  686.        do j=1,nocomp(/2)
  687.         ire=ire+1
  688.         lisinc(ire)=nocomp(j)
  689.         if (lisinc(ire).eq.'LX  ') call erreur(1125)
  690.         noelep(ire)=iel
  691.         re(1,ire,1)=vpocha(i,j)
  692.         call place(nomdd,lnomdd,ipo,nocomp(j))
  693.         if(ipo.eq.0) then
  694.         moterr(1:4)=nocomp(j)
  695.         moterr(5:11)='PRIMALE'
  696.         call erreur(1117)
  697.         endif
  698.         lisdua(ire)=nomdu(ipo)
  699.         noeled(ire)=iel
  700. *       write(6,*) ' 1 ire inc dua ',lisinc(ire),lisdua(ire)
  701.        enddo
  702.        enddo
  703.       enddo
  704.       mchpoi=ipochd
  705.       do ims=1,ipchp(/1)
  706.        msoupo=ipchp(ims)
  707.        segact msoupo
  708.        ipt1=igeoc
  709.        segact ipt1
  710.        mpoval=ipoval
  711.        segact mpoval
  712.        do i=1,ipt1.num(/2)
  713.         iel=iel+1
  714.         num(iel,1)=ipt1.num(1,i)
  715.         nbnd=nbnd+1
  716.        do j=1,nocomp(/2)
  717.         ire=ire+1
  718.         lisdua(ire)=nocomp(j)
  719.         noeled(ire)=iel
  720.         re(ire,1,1)= -vpocha(i,j)
  721.         call place(nomdu,lnomdu,ipo,nocomp(j))
  722.         if(ipo.eq.0) then
  723.         moterr(1:4)=nocomp(j)
  724.         moterr(5:10)='DUALE'
  725.         call erreur(1117)
  726.         endif
  727.         lisinc(ire)=nomdd(ipo)
  728.         if (lisinc(ire).eq.'LX  ') call erreur(1125)
  729.         noelep(ire)=iel
  730. *       write(6,*) ' 2 ire inc dua ',lisinc(ire),lisdua(ire)
  731.        enddo
  732.        enddo
  733.       enddo
  734. *  multiplicateur de lagrange
  735.       segact MCOORD*MOD
  736.       nbpts=nbpts+1
  737.       segadj mcoord
  738.       xl=0.d0
  739.       yl=0.d0
  740.       zl=0.d0
  741.       dl=0.d0
  742.       do i=2,num(/1)
  743.        ip=num(i,1)-1
  744.        xl=xl+xcoor(ip*(idim+1)+1)
  745.        if (idim.gt.1) yl=yl+xcoor(ip*(idim+1)+2)
  746.        if (idim.gt.2) zl=zl+xcoor(ip*(idim+1)+3)
  747.        dl=dl+xcoor(ip*(idim+1)+idim+1)
  748.       enddo
  749.       nbnnr=num(/1)-1
  750.       xl=xl/nbnnr
  751.       yl=yl/nbnnr
  752.       zl=zl/nbnnr
  753.       dl=dl/nbnnr
  754.       xcoor((nbpts-1)*(idim+1)+1)=xl
  755.       if (idim.gt.1) xcoor((nbpts-1)*(idim+1)+2)=yl
  756.       if (idim.gt.2) xcoor((nbpts-1)*(idim+1)+3)=zl
  757.       xcoor((nbpts-1)*(idim+1)+idim+1)=dl
  758.       lisinc(1)= 'LX'
  759.       lisdua(1)='FLX'
  760.       num(1,1)=nbpts
  761.       noelep(1)=1
  762.       noeled(1)=1
  763.       re(1,1,1)=0.D0
  764. *  un resultat
  765.       call ecrobj('RIGIDITE',mrigid)
  766.       SEGSUP MWGGM1
  767.       SEGSUP MWGGM2
  768.       SEGSUP MWGGM3
  769.       SEGSUP MWGGM4
  770.       SEGSUP MWGGM5
  771.       return
  772.       END
  773.  
  774.  
  775.  
  776.  
  777.  
  778.  
  779.  
  780.  
  781.  
  782.  
  783.  
  784.  
  785.  
  786.  
  787.  
  788.  
  789.  
  790.  
  791.  
  792.  
  793.  
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  
  800.  
  801.  
  802.  
  803.  

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