Télécharger la plaquette Cast3M


fr en

Télécharger rela.eso

Retour à la liste

Numérotation des lignes : 

rela

  1. C RELA      SOURCE    FANDEUR   22/03/01    21:15:07     11301          
  2.       SUBROUTINE RELA
  3. C
  4. C   CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C   C FABRIQUE UN OBJET ATTACHE CORRESPONDANT A UNE LIAISON ELEMENTAIRE
  6. C   CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  7. C
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8 (a-h,o-z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC CCHAMP
  14. -INC SMELSTR
  15. -INC SMCLSTR
  16. -INC SMSTRUC
  17. -INC SMELEME
  18. -INC SMCOORD
  19. -INC SMRIGID
  20. -INC SMCHPOI
  21. -INC SMATTAC
  22. -INC SMLREEL
  23.  
  24.       SEGMENT ITRA1(0)
  25.       SEGMENT IWOR1(0)
  26.       SEGMENT ITRA2(0)
  27.       SEGMENT ITRA3(0)
  28.       SEGMENT ITRA4(0)
  29.       SEGMENT ITRA5(0)
  30.       SEGMENT RCOEF(0)
  31.       SEGMENT IGEO(0)
  32.       SEGMENT IDEN(NPO)
  33.       SEGMENT ICO(NPO)
  34.  
  35.       SEGMENT SINCO
  36.        CHARACTER*(LOCOMP) INCO(ICMAX)
  37.       ENDSEGMENT
  38.  
  39.       SEGMENT NTABK(NLIGRE)
  40.  
  41.       SEGMENT MNOC
  42.         CHARACTER*(LOCOMP) NOCO(ICMAX,NPO)
  43.       ENDSEGMENT
  44.  
  45.       SEGMENT/MVAL/(VALE(ICMAX,NPO))
  46.  
  47.       CHARACTER*(LOCOMP) NOMCO
  48.       DATA ICMAX/15/
  49.  
  50.  
  51.       segact mcoord
  52.       CALL LIROBJ ('ELEMSTRU',IRET,0,IRETO1)
  53.       IRETO2=0
  54.       IF (IRETO1.EQ.0) CALL LIROBJ ('BLOQSTRU',IRET,0,IRETO2)
  55.       IF ((IRETO1+IRETO2).EQ.0) THEN
  56.          CALL RELA1
  57.          RETURN
  58.       ENDIF
  59.       SEGINI ITRA1
  60.       SEGINI IWOR1
  61.       MJON=0
  62.       NBCLST=0
  63.       IF (IRETO1.EQ.1) GO TO 15
  64.       IF (IRETO2.EQ.1) GO TO 25
  65.    1  CONTINUE
  66. C
  67. C   LECTURE DES MELSTR
  68. C
  69.       CALL LIROBJ('ELEMSTRU',IRET,0,IRETOU)
  70.       IF(IRETOU.EQ.0) GOTO 10
  71. 15    MELSTR=IRET
  72.       CALL LIRMOT(NOMDD,LNOMDD,IMOT,1)
  73.       IF(IERR.EQ.0) GOTO 2
  74. C  ***  OUBLI DE LA COMPOSANTE
  75.       CALL ERREUR(116)
  76.       GOTO 3
  77.    2  NOMCO=NOMDD(IMOT)
  78.       CALL LIRPRO(NBVAL,IPROG)
  79.       IF(IPROG.EQ.0) GOTO 3
  80.       SEGACT MELSTR
  81.       NBSTRU=ISOSTU(/1)
  82.       MSOSTU=ISOSTU(1)
  83.       MELEME=IMELEM(1)
  84.       SEGDES MELSTR
  85.       IF(NBSTRU.EQ.1) GOTO 4
  86. C  ***  LA SOUS-STRUCTURE N'EST PAS ELEMENTAIRE
  87.       INTERR(1)=MSOSTU
  88.       CALL ERREUR(90)
  89.    3  CONTINUE
  90.       SEGSUP ITRA1,IWOR1
  91.       RETURN
  92.    4  ITRA1(**)=MSOSTU
  93.       ITRA1(**)=MELEME
  94.       READ (NOMCO,FMT='(A4)') IPV
  95.       ITRA1(**)=IPV
  96.       ITRA1(**)=IPROG
  97.       GOTO 1
  98.    10 CONTINUE
  99. C
  100. C  LECTURE DES CLSTR
  101. C
  102.       CALL LIROBJ('BLOQSTRU',IRET,0,IRETOU)
  103.       IF(IRETOU.EQ.0) GOTO 20
  104. 25    MCLSTR=IRET
  105.       CALL LIRMOT(NOMDD,LNOMDD,IMOT,1)
  106.       IF(IERR.EQ.0) GOTO 11
  107. C  ***  OUBLI DE LA COMPOSANTE
  108.       CALL ERREUR(116)
  109.       GOTO 3
  110.    11 IF(NOMDD(IMOT).EQ.'LX  ') GOTO 12
  111. C  *** LA COMPOSANTE DOIT ETRE LX
  112.       CALL ERREUR(120)
  113.       GOTO 3
  114.    12 CONTINUE
  115.       CALL LIRPRO(NBVAL,IPROG)
  116.       IF(IPROG.EQ.0) GOTO 3
  117.       SEGACT MCLSTR
  118.       NBSTRU=ISOSTR(/1)
  119.       MSOSTU=ISOSTR(1)
  120.       IRIG=IRIGCL(1)
  121.       SEGDES MCLSTR
  122.       IF(NBSTRU.EQ.1) GOTO 13
  123. C  ***  LA SOUS-STRUCTURE N'EST PAS ELEMENTAIRE
  124.       INTERR(1)=MSOSTU
  125.       CALL ERREUR(90)
  126.       GOTO 3
  127.    13 IWOR1(**)=MSOSTU
  128.       IWOR1(**)=IRIG
  129.       IWOR1(**)=IPROG
  130.       GOTO 1
  131.    20 NBELST=ITRA1(/1)/4
  132.       IF(NBELST.EQ.0) GOTO 380
  133. C
  134. C   TRAITEMENT DES MELSTRS
  135. C   **********************
  136. C
  137.       SEGINI ITRA5
  138. C
  139. C   RECHERCHE DES SOUS STRUCTURES INTERVENANT DS LA LIAISON
  140. C   BOUCLE SUR L'ENSMBLE DES MELSTRS
  141. C   QUAND UNE SOUS STRUCTURE EST EPUISEE ITRA1( )=0
  142. C
  143.       DO 350 NB=1,NBELST
  144.       IT=4*(NB-1)
  145.       MSOSTU=ITRA1(IT+1)
  146.       IF(MSOSTU.EQ.0) GOTO 350
  147. C
  148. C   ***********       1        ***********
  149. C
  150. C   CREATION DES TABLEAUX AUXILLIAIRES :
  151. C   IGEO(IP)=NUM          LE IP-IEME PT A LE NUMERO NUM
  152. C   ITRA2(IKI)=IP         NUMERO D'ORDRE DU PT NUM DS IGEO
  153. C   ITRA2(IKI+1)=NOMCO    NOM DU DDL ASSOCIE AU PT
  154. C   RCOEF(I)=COEF         COEFFICIENT ASSOCIE AU DDL NOMCO  DU IP-IEME P
  155. C
  156.       SEGINI ITRA2,IGEO,RCOEF
  157. C
  158. C   RECHERCHE DES MELEMES D'UNE MEME SOUS STRUCTURE
  159. C
  160.       IP=0
  161.       NPO=0
  162.       DO 140 NBB=NB,NBELST
  163.       IT=4*(NBB-1)
  164.       IF(MSOSTU.NE.ITRA1(IT+1)) GOTO 140
  165.       MELEME=ITRA1(IT+2)
  166.       MLREEL=ITRA1(IT+4)
  167.       SEGACT MELEME,MLREEL
  168.       NBELEM=NUM(/2)
  169.       NBVAL=PROG(/1)
  170.       IF(NBVAL.EQ.NBELEM) GOTO 80
  171. C  *** LE NB DE COEF N'EST PAS EGAL AU NB DE PTS
  172.       CALL ERREUR(117)
  173.       SEGDES MELEME,MLREEL
  174.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF
  175.       GOTO 3
  176. C
  177. C   BOUCLE SUR LES PTS DU MELEME DU MELSTR
  178. C
  179.    80 DO 130 NBE=1,NBELEM
  180.       IKI=NUM(1,NBE)
  181.       IF(NPO.EQ.0) GOTO 100
  182.       DO 90 J=1,NPO
  183.       IPP=J
  184.       IF(IKI.EQ.IGEO(J)) GOTO 120
  185.    90 CONTINUE
  186.   100 IP=IP+1
  187.       IGEO(**)=IKI
  188.       IPP=IP
  189.   120 ITRA2(**)=IPP
  190.       ITRA2(**)=ITRA1(IT+3)
  191.       RCOEF(**)=PROG(NBE)
  192.   130 CONTINUE
  193.       SEGDES MELEME,MLREEL
  194.       NPO=IGEO(/1)
  195.       ITRA1(IT+1)=0
  196.   140 CONTINUE
  197.       I2=ITRA2(/1)
  198.       I21=I2-1
  199.       I3=RCOEF(/1)
  200.       I4=IGEO(/1)
  201.       IF(IIMPI.EQ.2) WRITE(IOIMP,1000)(I,ITRA2(I),I=1,I21,2)
  202.       IF(IIMPI.EQ.2) WRITE(IOIMP,1001)(I,ITRA2(I),I=2,I2,2)
  203.       IF(IIMPI.EQ.2) WRITE(IOIMP,1002)(I,RCOEF(I),I=1,I3)
  204.       IF(IIMPI.EQ.2) WRITE(IOIMP,1003)(I,IGEO(I) ,I=1,I4)
  205.  1000 FORMAT(1X,' ITRA2 ',10(I4,I4,1X))
  206.  1001 FORMAT(1X,' ITRA2 ',10(I4,1X,A4,1X))
  207.  1002 FORMAT(1X,' RCOEF ',8(I4,1PE12.5,1X))
  208.  1003 FORMAT(1X,' IGEO  ',10(I4,I4,1X))
  209. C
  210. C   **********     2     **********
  211. C
  212. C   RECHERCHE ET REPERAGE DES DDL
  213. C   CREATION DES TABLEAUX AUXILLIAIRES :
  214. C   NOCO(IC,IP)  NOM DU IC-IEME DDL DU PT IP
  215. C   IDEN(IP)     SI IDEN(IP)=IDEN(IPP) =>IP ET IPP ONT MEMES DDLS
  216. C   ICO(IP)      NB DE DDL DU PT IP
  217. C   INCO(NUCO)   NOM DU NUCO-IEME DDL
  218. C
  219.       SEGACT MSOSTU
  220.       MRIGID=ISRAID
  221.       SEGDES MSOSTU
  222.       SEGACT MRIGID
  223.       NRIGEL=IRIGEL(/2)
  224.       NDDL=0
  225.       SEGINI MNOC,IDEN,ICO,SINCO
  226.       ICMA=0
  227. C
  228. C    BOUCLE SUR LES POINTS DE LA SOUS STRUCTURE
  229. C
  230.       DO 250 IP=1,NPO
  231.       NDCP=0
  232. C
  233. C   BOUCLE SUR LES ZONES GEOMETRIQUES DE LA SOUS STRUCTURE
  234. C
  235.       DO 240 IAA=1,NRIGEL
  236.       MELEME=IRIGEL(1,IAA)
  237.       SEGACT MELEME
  238.       IF(ITYPEL.EQ.22) GOTO 235
  239.       NBELEM=NUM(/2)
  240.       NBPT=NUM(/1)
  241.       DO 150 NBE=1,NBELEM
  242.       DO 1501 NP=1,NBPT
  243.       IKI=NUM(NP,NBE)
  244.       NPEL=NP
  245.       IF(IKI.EQ.IGEO(IP)) GOTO 160
  246.  1501 CONTINUE
  247.   150 CONTINUE
  248.       GOTO 235
  249.   160 DESCR=IRIGEL(3,IAA)
  250.       SEGACT DESCR
  251.       NLIGRE=NOELEP(/1)
  252.       IC=0
  253.       ICC=0
  254. C
  255. C   BOUCLE SUR LES INCONNUES DE LA MATRICE DE RIGIDITE DE L'ELEMENT
  256. C
  257.       DO 230 I=1,NLIGRE
  258.       IF(NOELEP(I).NE.NPEL) GOTO 230
  259.       NOMCO=LISINC(I)
  260.       IF(NDDL.EQ.0) GOTO 180
  261. C
  262. C   BOUCLE SUR LES DDL TOTAUX DEJA CREES,ON DONNE UN NUMERO (NUCO) AU DD
  263. C
  264.       DO 170 ND=1,NDDL
  265.       NUCO=ND
  266.       IF(NOMCO.EQ.INCO(ND)) GOTO 190
  267.   170 CONTINUE
  268.   180 IC=IC+1
  269.       NUCO=NDDL+IC
  270.       INCO(NUCO)=NOMCO
  271.   190 CONTINUE
  272.       IF(NDCP.EQ.0) GOTO 210
  273. C
  274. C   BOUCLE SUR LES DDL DU PT DEJA CREES
  275. C
  276.       DO 200 NDC=1,NDCP
  277.       IF(NOMCO.EQ.NOCO(NDC,IP)) GOTO 220
  278.   200 CONTINUE
  279.   210 ICC=ICC+1
  280.       NDIC=NDCP+ICC
  281.       IF(NDIC.LE.ICMAX) GOTO 215
  282. C  ***  A LA  NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1)
  283. C       TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE
  284.       CALL ERREUR(119)
  285.       SEGDES DESCR,MELEME,MRIGID,MSOSTU
  286.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO
  287.       GOTO 3
  288.   215 NOCO(NDIC,IP)=NOMCO
  289.       IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1
  290.       IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1)
  291.   220 CONTINUE
  292.   230 CONTINUE
  293.       SEGDES DESCR
  294.       NDDL=NDDL+IC
  295.       NDCP=NDCP+ICC
  296.   235 CONTINUE
  297.       SEGDES MELEME
  298.   240 CONTINUE
  299.       ICO(IP)=NDCP
  300.       IF(NDCP.GT.ICMA) ICMA=NDCP
  301.   250 CONTINUE
  302.       I1=NOCO(/2)
  303.       I2=NOCO(/3)
  304.       I3=IDEN(/1)
  305.       I4=ICO(/1)
  306.       I5=INCO(/2)
  307.       IF(IIMPI.EQ.2) WRITE(IOIMP,1004)((J,I,NOCO(I,J),I=1,I1),J=1,I2)
  308.       IF(IIMPI.EQ.2) WRITE(IOIMP,1005)(I,IDEN(I),I=1,I3)
  309.       IF(IIMPI.EQ.2) WRITE(IOIMP,1006)(I,ICO(I),I=1,I4)
  310.       IF(IIMPI.EQ.2) WRITE(IOIMP,1007)(I,INCO(I),I=1,I5)
  311.  1004 FORMAT(1X,' NOCO ',8(I4,1X,I4,1X,A4,1X))
  312.  1005 FORMAT(1X,' IDEN ',10(I4,1X,I4,1X))
  313.  1006 FORMAT(1X,' ICO  ',10(I4,1X,I4,1X))
  314.  1007 FORMAT(1X,' INCO ',10(I4,1X,A4,1X))
  315.       SEGDES MRIGID
  316.       SEGSUP SINCO
  317. C
  318. C   **********     3     **********
  319. C
  320. C   COMPATIBILITE DES DONNEES CORRESPONDANT AUX DDL ET
  321. C   CREATION DU TABLEAU AUXILLIAIRE :
  322. C   VALE(IC,IP)  COEF POUR LE IC-IEME DDL DU IP-IEME PT
  323. C
  324.       IKIMA=ITRA2(/1)/2
  325.       ICMAX=ICMA
  326.       SEGINI MVAL
  327. C
  328. C   BOUCLE SUR LES POINTS DE LA SOUS-STRUCTURE
  329. C
  330.       DO 290 IP=1,NPO
  331.       NDCP=ICO(IP)
  332.       DO 255 IC=1,ICMAX
  333.       VALE(IC,IP)=0.
  334.   255 CONTINUE
  335. C
  336. C   RECHERCHE DU(ES) DDL DE LIAISON DU PT
  337. C   ON PARCOURS LE TABLEAU ITRA2
  338. C
  339.       DO 280 IKI=1,IKIMA
  340.       IT=2*(IKI-1)
  341.       IKIN=ITRA2(IT+1)
  342.       IF(IKIN.NE.IP) GOTO 280
  343.       WRITE (NOMCO,FMT='(A4)') ITRA2(IT+2)
  344. C
  345. C   BOUCLE SUR LES DDL DU PT
  346. C
  347.       DO 260 IC=1,NDCP
  348.       ICC=IC
  349.       IF(NOMCO.EQ.NOCO(IC,IP)) GOTO 270
  350.   260 CONTINUE
  351. C  *** LE DDL N'EXISTE PAS
  352.       INTERR(1)=MSOSTU
  353.       MOTERR=NOMCO
  354.       CALL ERREUR(118)
  355.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MVAL,MNOC,ICO,IDEN
  356.       GOTO 3
  357.   270 VALE(ICC,IP)=RCOEF(IKI)
  358.   280 CONTINUE
  359.   290 CONTINUE
  360.       SEGSUP ITRA2,RCOEF
  361.       I1=VALE(/1)
  362.       I2=VALE(/2)
  363.       IF(IIMPI.EQ.2) WRITE(IOIMP,1008)((J,I,VALE(I,J),I=1,I1),J=1,I2)
  364.  1008 FORMAT(1X,' VALE ',5(I4,1X,I4,1X,1PE12.5,1X))
  365. C
  366. C    **********     4     **********
  367. C
  368.       SEGINI ITRA4
  369.       DO 330 IP=1,NPO
  370.       IA=IDEN(IP)
  371.       IF(IA.EQ.0) GOTO 330
  372.       SEGINI ITRA3
  373. C
  374. C    CREATION DES MSOUPO DU CHAMPOINT    (ITRA4)
  375. C    RECHERCHE DES PTS AYANT LES MEMES DDDL   (ITRA3)
  376. C
  377.       DO 300 IPP=IP,NPO
  378.       IF(IA.NE.IDEN(IPP)) GOTO 300
  379.       ITRA3(**)=IPP
  380.       IDEN(IPP)=0
  381.   300 CONTINUE
  382.       NC=ICO(IP)
  383.       SEGINI MSOUPO
  384.       ITRA4(**)=MSOUPO
  385.       NBSOUS=0
  386.       NBREF=0
  387.       NBNN=1
  388.       NBELEM=ITRA3(/1)
  389.       SEGINI MELEME
  390.       IGEOC=MELEME
  391.       ITYPEL=1
  392.       N=NBELEM
  393.       SEGINI MPOVAL
  394.       IPOVAL=MPOVAL
  395.       DO 310 IC=1,NC
  396.       NOCOMP(IC)=NOCO(IC,IP)
  397.       NOHARM(IC)=NIFOUR
  398.   310 CONTINUE
  399.       DO 320 NBE=1,NBELEM
  400.       IPP=ITRA3(NBE)
  401.       NUM(1,NBE)=IGEO(IPP)
  402.       DO 3201 IC=1,NC
  403.       DO 315 ICC=1,NC
  404.       IC1=ICC
  405.       IF(NOCO(IC1,IPP).EQ.NOCOMP(IC)) GOTO 317
  406.   315 CONTINUE
  407.   317 VPOCHA(NBE,IC)=VALE(IC1,IPP)
  408.  3201 CONTINUE
  409.   320 CONTINUE
  410.       SEGDES MELEME,MPOVAL,MSOUPO
  411.       SEGSUP ITRA3
  412.   330 CONTINUE
  413.       SEGSUP IDEN,ICO,IGEO,MNOC,MVAL
  414.       NSOUPO=ITRA4(/1)
  415.       NAT=1
  416.       SEGINI MCHPOI
  417.       IFOPOI=IFOUR
  418.       DO 340 NS=1,NSOUPO
  419.       IPCHP(NS)=ITRA4(NS)
  420.   340 CONTINUE
  421.       SEGDES MCHPOI
  422.       SEGSUP ITRA4
  423. C
  424. C    **********           **********
  425. C
  426.       ITRA5(**)=MSOSTU
  427.       ITRA5(**)=MCHPOI
  428.   350 CONTINUE
  429. C
  430. C   CREATION DU MJONCT
  431. C
  432.   355 N=ITRA5(/1)/2
  433.       SEGINI MJONCT
  434.       MJOTYP='MECA'
  435.       MJODDL='LX'
  436. C  NBCLST=0 LIAISON LIBRE  NBCLST#0 LIAISON BLOQUE
  437.       IF(NBCLST.NE.0) MJODDL='FLX'
  438.       SEGACT MCOORD*MOD
  439.       NBNO=nbpts
  440.       XCOOR(**)=0.
  441.       XCOOR(**)=0.
  442.       IF(IDIM.EQ.3) XCOOR(**)=0.
  443.       XCOOR(**)=0.
  444.       nbpts=nbpts+1
  445.       NBNN=1
  446.       NBELEM=1
  447.       NBREF=0
  448.       NBSOUS=0
  449.       SEGINI MELEME
  450.       ITYPEL=1
  451.       NUM(1,1)=NBNO+1
  452.       SEGDES MELEME
  453.       MJOPOI=MELEME
  454.       IF(NBCLST.EQ.0) MJOPO1=NBNO+1
  455.       IF(NBCLST.NE.0) MJOPO2=NBNO+1
  456.       DO 360 NN=1,N
  457.       NNN=2*NN
  458.       ISTRJO(NN)=ITRA5(NNN-1)
  459.       IPCHJO(NN)=ITRA5(NNN)
  460.   360 CONTINUE
  461.       SEGSUP ITRA5
  462.       SEGDES MJONCT
  463.       IF(MJON.EQ.0) MJON=MJONCT
  464.       IF(NBCLST.NE.0) GOTO 500
  465.   380 NBCLST=IWOR1(/1)/3
  466.       IF(NBCLST.EQ.0) GOTO 500
  467. C
  468. C    TRAITEMENT DES CLSTRS
  469. C    *********************
  470. C
  471.       SEGINI ITRA5
  472. C
  473. C   RECHERCHE DES SOUS STRUCTURES INTERVENANT DS LA LIAISON
  474.  
  475. C   BOUCLE SUR L'ENSEMBLE DES CLSTR
  476. C
  477.       DO 490 NB=1,NBCLST
  478.       IT=3*(NB-1)
  479.       MSOSTU=IWOR1(IT+1)
  480.       IF(MSOSTU.EQ.0) GOTO 490
  481.       NPO=0
  482.       SEGINI IGEO,RCOEF
  483. C
  484. C   RECHERCHE DES CLSTR D'UNE MEME SOUS STRUCTURE
  485. C
  486.       DO 470 NBB=NB,NBCLST
  487.       IT=3*(NBB-1)
  488.       IF(MSOSTU.NE.IWOR1(IT+1)) GOTO 470
  489.       MRIGID=IWOR1(IT+2)
  490.       SEGACT MRIGID
  491.       NRIGEL=IRIGEL(/2)
  492. C
  493. C   BOUCLE SUR LES BLOCAGES DE LA SOUS STRUCTURE
  494. C
  495.       DO 440 IAA=1,NRIGEL
  496. C   RECHERCHE DE LA POSITION DES INCONNUES DE LAGRANGE
  497.       DESCR=IRIGEL(3,IAA)
  498.       SEGACT DESCR
  499.       NLIGRE=LISINC(/2)
  500.       SEGINI NTABK
  501.       JK=0
  502.       DO 400 I=1,NLIGRE
  503.       NOMCO=LISINC(I)
  504.       IF(NOMCO.NE.'LX  ') GOTO 400
  505.       JK=JK+1
  506.       NTABK(JK)=NOELEP(I)
  507.   400 CONTINUE
  508.       SEGDES DESCR
  509.       MELEME=IRIGEL(1,IAA)
  510.       SEGACT MELEME
  511.       NBELEM=NUM(/2)
  512. C
  513. C   BOUCLES SUR LES NOEUDS DU BLOCAGE
  514. C
  515.       DO 430 NBE=1,NBELEM
  516.       DO 420 NP=1,JK
  517.       IKI=NUM(NTABK(NP),NBE)
  518.       IF(NPO.EQ.0) GOTO 415
  519.       DO 410 J=1,NPO
  520.       IF(IKI.EQ.IGEO(J)) GOTO 450
  521.   410 CONTINUE
  522.   415 IGEO(**)=IKI
  523.   420 CONTINUE
  524.   430 CONTINUE
  525.       SEGSUP NTABK
  526.       SEGDES MELEME
  527.       NPO=IGEO(/1)
  528.   440 CONTINUE
  529.       MLREEL=IWOR1(IT+3)
  530.       SEGACT MLREEL
  531.       NBVAL=PROG(/1)
  532.       IF(NBVAL.EQ.NPO) GOTO 460
  533. C  *** LE NB DE COEF N'EST PAS EGAL AU NB DE PTS
  534.       CALL ERREUR(117)
  535.       SEGDES MLREEL
  536.   445 SEGDES MRIGID
  537.       SEGSUP IGEO,RCOEF
  538.       GOTO 3
  539.   450 CALL ERREUR(120)
  540.       SEGDES MELEME
  541. C  *** UN DDL EST DONNE PLUSIEURS FOIS
  542.       GOTO 445
  543.   460 IWOR1(IT+1)=0
  544.       SEGDES MRIGID
  545.       DO NV=1,NBVAL
  546.         RCOEF(**)=PROG(NV)
  547.       ENDDO
  548.       SEGDES MLREEL
  549.   470 CONTINUE
  550.       IF(IIMPI.EQ.2) WRITE(IOIMP,1009)(I,IGEO(I),RCOEF(I),I=1,NPO)
  551.  1009 FORMAT(1X,' IGEO=',5(I4,1X,I4,1X,1PE12.5,1X))
  552. C
  553. C   CREATION DU CHAMPOINT   (ITRA5)
  554. C
  555.       NSOUPO=1
  556.       NAT=1
  557.       SEGINI MCHPOI
  558.       MOCHDE='        '
  559.       MTYPOI='        '
  560.       IFOPOI=IFOUR
  561.       NC=1
  562.       SEGINI MSOUPO
  563.       IPCHP(1)=MSOUPO
  564.       SEGDES MCHPOI
  565.       ITRA5(**)=MSOSTU
  566.       ITRA5(**)=MCHPOI
  567.       NBSOUS=0
  568.       NBREF=0
  569.       NBNN=1
  570.       NBELEM=NPO
  571.       SEGINI MELEME
  572.       IGEOC=MELEME
  573.       ITYPEL=1
  574.       N=NBELEM
  575.       SEGINI MPOVAL
  576.       DO 480 I=1,N
  577.       NUM(1,I)=IGEO(I)
  578.       VPOCHA(I,1)=RCOEF(I)
  579.   480 CONTINUE
  580.       NOCOMP(1)='LX'
  581.       NOHARM(1)=NIFOUR
  582.       IPOVAL=MPOVAL
  583.       SEGDES MELEME,MPOVAL,MSOUPO
  584.       SEGSUP IGEO,RCOEF
  585.   490 CONTINUE
  586.       GOTO 355
  587. C
  588. C   CREATION DU MATTAC
  589. C
  590.   500 SEGSUP ITRA1,IWOR1
  591.       IF (MJON.EQ.0) THEN
  592. C  *** PAS D'OPERANDE CORRECT
  593.         CALL ERREUR(92)
  594.         RETURN
  595.       ENDIF
  596.       N=1
  597.       M=0
  598. C   SI MJON # MJONCT LA LIAISON EST MIXTE
  599.       IF(MJON.NE.MJONCT) N=2
  600.       IF(MJON.NE.MJONCT) M=1
  601.       SEGINI MSOUMA
  602.       ITYATT='MECA'
  603.       IGEOCH=0
  604.       IPHYCH=0
  605.       IATREL(1)=MJON
  606.       IF(N.EQ.1) GOTO 520
  607.       IATREL(2)=MJONCT
  608. C  *** CREATION DE LA MATRICE DUE A LA LIAISON MIXTE
  609. *      LVAL=3
  610.       NLIGRE=2
  611.       NLIGRP=2
  612.       NLIGRD=2
  613.       nelrig=1
  614.       SEGINI XMATRI
  615.       RE(1,1,1)=0.
  616.       RE(2,1,1)=-1.
  617.       RE(2,2,1)=0.
  618.       RE(1,2,1)=-1.
  619.       SEGDES XMATRI
  620. *      NELRIG=1
  621. *      SEGINI IMATRI
  622. *      IMATTT(1)=XMATRI
  623. *      SEGDES IMATRI
  624.       NLIGRP=2
  625.       NLIGRD=2
  626.       SEGINI DESCR
  627.       NOELEP(1)=1
  628.       NOELEP(2)=2
  629.       NOELED(1)=1
  630.       NOELED(2)=2
  631.       LISINC(1)='BETA'
  632.       LISINC(2)='FBET'
  633.       LISDUA(1)='FBET'
  634.       LISDUA(2)='BETA'
  635.       SEGDES DESCR
  636.       NBNN=2
  637.       NBELEM=1
  638.       NBSOUS=0
  639.       NBREF=0
  640.       SEGINI MELEME
  641.       ITYPEL=23
  642.       NUM(1,1)=MJOPO1
  643.       NUM(2,1)=MJOPO2
  644.       SEGDES MELEME
  645.       NRIGEL=1
  646.       SEGINI MRIGID
  647.       MTYMAT='RIGIDITE'
  648.       IFORIG=IFOUR
  649.       COERIG(1)=1.D0
  650.       IRIGEL(1,1)=MELEME
  651.       IRIGEL(2,1)=0
  652.       IRIGEL(3,1)=DESCR
  653.       IRIGEL(4,1)=xMATRI
  654.       ICHOLE=0
  655.       SEGDES MRIGID
  656.       IPMATK(1)=MRIGID
  657.   520 CONTINUE
  658.       SEGDES MSOUMA
  659.       N=1
  660.       SEGINI MATTAC
  661.       LISATT(1)=MSOUMA
  662.       CALL ECROBJ('ATTACHE ',MATTAC)
  663.       SEGDES MATTAC
  664.  
  665. c      RETURN
  666.       END
  667.  
  668.  
  669.  

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