Télécharger la plaquette Cast3M


fr en

Télécharger jonct.eso

Retour à la liste

Numérotation des lignes : 

jonct

  1. C JONCT     SOURCE    CB215821  26/08/24    21:16:58     12622          
  2.       SUBROUTINE JONCT
  3. C
  4. C   CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C     FABRIQUE UN OBJET ATTACHE DECRIVANT LA LIAISON ENTRE PLUSIEURS
  6. C     ELEMENTS DE STRUCTURE,LIAISON DEFINIE PAR UN NOMBRE QUELCONQUE
  7. C     DE LIAISONS ELEMENTAIRES
  8. C        *********************
  9. C
  10. C   SYNTAXE:(EXTENSION DE RELA)
  11. C      ATT= JON ELSTR1   DDL1    PROG1 ....ELSTRN DDLN PROGN
  12. C               ELSTRN+1 DDLN+1  PROGN+1...ELSTRP DDLP PROGP
  13. C              (DDDD
  14. C               ......
  15. C               ...........................ELSTRQ DDLQ PROGQ)
  16. C
  17. C     VERSION 3 UN SEUL MSOUPO PAR RELATION ELEMENTAIRE ET PAR POINT
  18. C
  19. C
  20. C     ATTENTION:LE TABLEAU DES IDEN(IP) DOIT ETRE DES I*4
  21. C   CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  22. C
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8 (A-H,O-Z)
  25.  
  26. -INC PPARAM
  27. -INC CCOPTIO
  28. -INC CCHAMP
  29.  
  30. -INC SMELSTR
  31. -INC SMCLSTR
  32. -INC SMSTRUC
  33. -INC SMELEME
  34. -INC SMCOORD
  35. -INC SMRIGID
  36. -INC SMCHPOI
  37. -INC SMATTAC
  38. -INC SMLREEL
  39.  
  40. -INC SMCHAML
  41.  
  42.       SEGMENT ITRA1(0)
  43.       SEGMENT IWOR1(0)
  44.       SEGMENT ITRA2(0)
  45.       SEGMENT ITRA3(0)
  46.       SEGMENT ITRA4(0)
  47.       SEGMENT ITRA5(0)
  48.       SEGMENT RCOEF(0)
  49.       SEGMENT IGEO(0)
  50.       SEGMENT IDEN(NPO)
  51.       SEGMENT ICO(NPO)
  52.       SEGMENT SINCO
  53.        CHARACTER*(LOCOMP) INCO(ICCMAX)
  54.       ENDSEGMENT
  55.       SEGMENT MNOC
  56.        CHARACTER*(LOCOMP) NOCO(ICCMAX,NPO)
  57.       ENDSEGMENT
  58.       SEGMENT/MVAL/(VALE(ICCMAX,NPO))
  59.       CHARACTER*4 MOMAS(1),IDELI(1)
  60.       CHARACTER*(LOCOMP) NOMCO
  61.       DATA ICCMAX/30/
  62.       DATA IDELI/'DDDD'/,MOMAS/'MASS'/
  63.       SEGACT MCOORD*MOD
  64.       SEGINI ITRA1
  65.       NBRELA=0
  66.       LDD=0
  67.       LDU=0
  68.       CALL LIRMOT(MOMAS,1,IMASS,0)
  69.  5001 CONTINUE
  70.       NBRELA =NBRELA+1
  71.    1  CONTINUE
  72. C
  73. C   LECTURE DES MELSTR
  74. C
  75.       CALL LIROBJ('ELEMSTRU',IRET,0,IRETOU)
  76.       IF(IRETOU.EQ.0) GOTO 10
  77.       MELSTR=IRET
  78.       CALL LIRMOT(NOMDD,LNOMDD,IMOT,0)
  79.       IF(IERR.NE.0) RETURN
  80.       IF(IMOT.NE.0) THEN
  81.              LDD=1
  82.              NOMCO=NOMDD(IMOT)
  83.              GO TO 2
  84.       ENDIF
  85.       CALL LIRMOT(NOMDU,LNOMDD,IMOT,1)
  86.       IF(IERR.NE.0) RETURN
  87.       IF(IMOT.NE.0) THEN
  88.              LDU=1
  89.              NOMCO=NOMDU(IMOT)
  90.              GO TO 2
  91.       ENDIF
  92. C  ***  OUBLI DE LA COMPOSANTE
  93.       CALL ERREUR(116)
  94.       GOTO 3
  95.    2  CONTINUE
  96.       CALL LIRPRO(NBVAL,IPROG)
  97.       IF(IPROG.EQ.0) GOTO 3
  98.       SEGACT MELSTR
  99.       NBSTRU=ISOSTU(/1)
  100.       MSOSTU=ISOSTU(1)
  101.       MELEME=IMELEM(1)
  102.       SEGDES MELSTR
  103.       IF(NBSTRU.EQ.1) GOTO 4
  104. C  ***  LA SOUS-STRUCTURE N'EST PAS ELEMENTAIRE
  105.       INTERR(1)=MSOSTU
  106.       CALL ERREUR(90)
  107.    3  CONTINUE
  108.       SEGSUP ITRA1
  109.       RETURN
  110.    4  ITRA1(**)=MSOSTU
  111.       ITRA1(**)=MELEME
  112.       READ (NOMCO,FMT='(A4)') IPV
  113.       ITRA1(**)=IPV
  114.       ITRA1(**)=IPROG
  115. C*******RECHERCHE DU SEPARATEUR D'EXPRESSIONS
  116.       CALL LIRMOT(IDELI,1,IMOT,0)
  117.       IF(IERR.NE.0) RETURN
  118.       IF(IMOT.EQ.0) GO TO 1
  119.            READ (IDELI,FMT='(A4)') IPV
  120.            ITRA1(**)=IPV
  121.            GO TO 5001
  122.    10 CONTINUE
  123.       NITRA1=ITRA1(/1)
  124.       IF(IIMPI.EQ.2) WRITE(IOIMP,7) NITRA1
  125.    7  FORMAT(2X,'NITRA1',I4)
  126.       K=0
  127.    11 K=K+1
  128.       IF(IIMPI.EQ.2) WRITE(IOIMP,12)(KK,ITRA1(KK),KK=K,K+3)
  129.    12 FORMAT(2X,2('ITRA(',I4,')=',I4,2X),'ITRA1(',I4,')=',A4,1X,'ITRA1
  130.      &(',I4,')=',I4)
  131.       KS=K+4
  132.       IF(KS.LE.NITRA1)THEN
  133.            READ (IDELI,FMT='(A4)') IPV
  134.            IF(ITRA1(KS).EQ.IPV)THEN
  135.                K=KS
  136.              IF(IIMPI.EQ.2)  WRITE(IOIMP,13) ITRA1(KS)
  137.    13 FORMAT(10X,A4)
  138.            ELSE
  139.                K=K+3
  140.            ENDIF
  141.            GO TO 11
  142.       ENDIF
  143. C
  144. C   TRAITEMENT DES MELSTRS
  145. C   **********************
  146. C
  147.       IF(NBRELA.EQ.0) RETURN
  148.       N=NBRELA
  149.       M=0
  150.       SEGINI MSOUMA
  151.       ITYATT='MECA'
  152.       IGEOCH=0
  153.       IPHYCH=0
  154.       IDD1=0
  155.       IF(IIMPI.EQ.2 ) WRITE(IOIMP,8) NBRELA
  156.    8  FORMAT(2X,'NBRELA=',I4)
  157. C
  158. C      BOUCLE SUR LES RELATIONS ELEMENTAIRES ECRITES
  159. C      *********************************************
  160. C
  161.       DO 520 NNNN=1,NBRELA
  162.       IF(IIMPI.EQ.2)  WRITE(IOIMP,9) NNNN
  163.    9  FORMAT(2X,'NNNN=',I4)
  164. C      PRISE EN COMPTE DU SEPARATEUR
  165.       IDD1=IDD1+1
  166. C      MEMORISATION DE LA POSITION DANS ITRA1 DU DEBUT DE LA RELATION
  167.       IT1 =IDD1
  168.       NBELST=0
  169. C******************COMPTAGES
  170.    15 IDD1=IDD1+4
  171.       IF(IIMPI.EQ.2) WRITE(IOIMP,17) IDD1
  172.    17 FORMAT(2X,'IDD1=',I4)
  173.       NBELST=NBELST+1
  174.       IF(IDD1.GE.NITRA1) GO TO 16
  175.       READ (IDELI,FMT='(A4)') IPV
  176.       IF(ITRA1(IDD1).NE.IPV) GO TO 15
  177. C *****************
  178.    16 CONTINUE
  179.       SEGINI ITRA5
  180. C
  181. C   RECHERCHE DES SOUS STRUCTURES INTERVENANT DS LA LIAISON
  182. C   BOUCLE SUR L'ENSMBLE DES MELSTRS
  183. C   QUAND UNE SOUS STRUCTURE EST EPUISEE ITRA1( )=0
  184. C
  185.       DO 350 NB=1,NBELST
  186.       IT=(IT1-1)+4*(NB-1)
  187.       MSOSTU=ITRA1(IT+1)
  188.       IF(MSOSTU.EQ.0) GOTO 350
  189. C
  190. C   ***********       1        ***********
  191. C
  192. C   CREATION DES TABLEAUX AUXILIAIRES :
  193. C   IGEO(IP)=NUM          LE IP-IEME PT A LE NUMERO NUM
  194. C   ITRA2(IKI)=IP         NUMERO D'ORDRE DU PT NUM DS IGEO
  195. C   ITRA2(IKI+1)=NOMCO    NOM DU DDL ASSOCIE AU PT
  196. C   RCOEF(I)=COEF         COEFFICIENT ASSOCIE AU DDL NOMCO  DU IP-IEME P
  197. C
  198.       SEGINI ITRA2,IGEO,RCOEF
  199. C
  200. C   RECHERCHE DES MELEMES D'UNE MEME SOUS STRUCTURE
  201. C
  202.       IP=0
  203.       NPO=0
  204.       DO 140 NBB=NB,NBELST
  205.       IT=(IT1-1)+4*(NBB-1)
  206.       IF(MSOSTU.NE.ITRA1(IT+1)) GOTO 140
  207.       MELEME=ITRA1(IT+2)
  208.       MLREEL=ITRA1(IT+4)
  209.       SEGACT MELEME,MLREEL
  210.       NBELEM=NUM(/2)
  211.       NBVAL=PROG(/1)
  212.       IF(NBVAL.EQ.NBELEM) GOTO 80
  213. C  *** LE NB DE COEF N'EST PAS EGAL AU NB DE PTS
  214.       CALL ERREUR(117)
  215.       SEGDES MELEME
  216.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF
  217.       GOTO 3
  218. C
  219. C   BOUCLE SUR LES PTS DU MELEME DU MELSTR
  220. C
  221.    80 DO 130 NBE=1,NBELEM
  222.       IKI=NUM(1,NBE)
  223.       IF(NPO.EQ.0) GOTO 100
  224.       DO 90 J=1,NPO
  225.       IPP=J
  226.       IF(IKI.EQ.IGEO(J)) GOTO 120
  227.    90 CONTINUE
  228.   100 IP=IP+1
  229.       IGEO(**)=IKI
  230.       IPP=IP
  231.   120 ITRA2(**)=IPP
  232.       ITRA2(**)=ITRA1(IT+3)
  233.       RCOEF(**)=PROG(NBE)
  234.   130 CONTINUE
  235.       SEGDES MELEME
  236. *PV horodatage  SEGSUP MLREEL
  237.       NPO=IGEO(/1)
  238.       ITRA1(IT+1)=0
  239.   140 CONTINUE
  240.       I2=ITRA2(/1)
  241.       I21=I2-1
  242.       I3=RCOEF(/1)
  243.       I4=IGEO(/1)
  244.       IF(IIMPI.EQ.2) WRITE(IOIMP,1000)(I,ITRA2(I),I=1,I21,2)
  245.       IF(IIMPI.EQ.2) WRITE(IOIMP,1001)(I,ITRA2(I),I=2,I2,2)
  246.       IF(IIMPI.EQ.2) WRITE(IOIMP,1002)(I,RCOEF(I),I=1,I3)
  247.       IF(IIMPI.EQ.2) WRITE(IOIMP,1003)(I,IGEO(I) ,I=1,I4)
  248.  1000 FORMAT(1X,' ITRA2 ',10(I4,I4,1X))
  249.  1001 FORMAT(1X,' ITRA2 ',10(I4,1X,A4,1X))
  250.  1002 FORMAT(1X,' RCOEF ',8(I4,1PE12.5,1X))
  251.  1003 FORMAT(1X,' IGEO  ',10(I4,I4,1X))
  252. C
  253. C   **********     2     **********
  254. C
  255. C   RECHERCHE ET REPERAGE DES DDL
  256. C   CREATION DES TABLEAUX AUXILIAIRES :
  257. C   NOCO(IC,IP)  NOM DU IC-IEME DDL DU PT IP
  258. C   IDEN(IP)     SI IDEN(IP)=IDEN(IPP) =>IP ET IPP ONT MEMES DDLS
  259. C   ICO(IP)      NB DE DDL DU PT IP
  260. C   INCO(NUCO)   NOM DU NUCO-IEME DDL
  261. C
  262.       SEGACT MSOSTU
  263.       IF(ISRAID.EQ.0) THEN
  264.         IFOCHS = IFOCHE
  265.         MCHELM=ISCHAM(1)
  266.         SEGDES MSOSTU
  267.         SEGACT,MCHELM
  268.         NSOUS=IMACHE(/1)
  269.         NDDL=0
  270.         SEGINI MNOC,IDEN,ICO,SINCO
  271.         ICMA=0
  272. C
  273. C  ******** BOUCLE SUR LES POINTS DE IGEO ********
  274. C
  275.         DO 2250 IP=1,NPO
  276.            NDCP=0
  277. C
  278. C  ******** BOUCLE SUR LES ZONES GEO.ELEM. DU CHAMP DE MATERIAU
  279. C
  280.            DO 2240 IAB=1,NSOUS
  281.                 MELEME=IMACHE(IAB)
  282.                 MCHAML=ICHAML(IAB)
  283.                 SEGACT MELEME
  284.                 IF(ITYPEL.EQ.22) GO TO 2235
  285.                 NBELEM=NUM(/2)
  286.                 NBPT=NUM(/1)
  287.                 DO 5002 NBE=1,NBELEM
  288.                 DO 2150 NP=1,NBPT
  289.                   IKI=NUM(NP,NBE)
  290.                   NPEL=NP
  291.                   IF(IKI.EQ.IGEO(IP)) GO TO 2160
  292.  2150           CONTINUE
  293.  5002           CONTINUE
  294. C           LE POINT N'APPARTIENT PAS A LA ZONE:SORTIR
  295.                 GO TO 2235
  296.  2160          CONTINUE
  297.                 SEGACT MCHAML
  298.                 NNINCO=NOMCHE(/2)
  299.                 IC=0
  300.                 ICC=0
  301. C
  302. C ********* BOUCLE SUR TOUS LES CHAMPS POSSIBLES
  303. C
  304.                 DO 2225 NN=1,NNINCO
  305. C
  306. C ********* RECHERCHE DU MOT"DEPLACEMENT"OU"FORCE"
  307. C
  308.       LDPROD=LDD+2*LDU
  309.       IF (IIMPI.EQ.2) WRITE(IOIMP,2165) LDPROD
  310.  2165 FORMAT(5X,'LDPROD=',I2)
  311.                       NCP=NN
  312.                       DO 2220 NCP1=NCP,NCP
  313.                          NOMCO=NOMCHE(NCP1)
  314. C
  315. C ****LE DEGRE DE LIB NOMCO EXISTE-T-IL DEJA DANS LES DDL CREES ?
  316. C
  317.                          IF(NDDL.EQ.0) GO TO 2180
  318.                          DO 2170 ND=1,NDDL
  319.                               NUCO=ND
  320.                               IF(NOMCO.EQ.INCO(ND)) GO TO 2190
  321.  2170                    CONTINUE
  322.  2180                 IC=IC+1
  323.                       NUCO=NDDL+IC
  324.                       INCO(NUCO)=NOMCO
  325.  2190                 CONTINUE
  326. C
  327. C ********LE DEGRE DE LIB NOMCO EXISTE-T-IL DANS LES DDL CREES POUR
  328. C             LE POINT COURANT IGEO(IP)
  329. C
  330.                       IF(NDCP.EQ.0)GO TO 2210
  331.                       DO 2200 NDC=1,NDCP
  332.                           IF(NOMCO.EQ.NOCO(NDC,IP)) GO TO 2220
  333.  2200                 CONTINUE
  334.  2210                 ICC=ICC+1
  335.                       NDIC=NDCP+ICC
  336.                       IF(IIMPI.EQ.2) WRITE(IOIMP,2211) NOMCO
  337.  2211                 FORMAT(5X,'NOMCO=',A)
  338.                       IF(IIMPI.EQ.2) WRITE(IOIMP,2214) NDIC
  339.                       IF(NDIC.LE.ICCMAX) GO TO 2215
  340. C        ERREUR
  341. C       TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE
  342.       IF(IIMPI.EQ.2) WRITE (IOIMP,2214) NDIC
  343.  2214 FORMAT(10X,'NDIC=',I4)
  344.       SEGDES MELEME
  345.       CALL ERREUR(119)
  346.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO
  347.       GOTO 3
  348.  2215                 NOCO(NDIC,IP)=NOMCO
  349. C  ***  A LA  NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1)
  350.                       IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1
  351.                       IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1)
  352.  2220                 CONTINUE
  353.  2225                 CONTINUE
  354.  2230           CONTINUE
  355.                 NDDL=NDDL+IC
  356.                 NDCP=NDCP+ICC
  357.  2235           CONTINUE
  358.                 SEGDES MELEME
  359.                 SEGDES MCHAML
  360.  2240      CONTINUE
  361.            ICO(IP)=NDCP
  362.            IF(NDCP.GT.ICMA) ICMA=NDCP
  363.  2250   CONTINUE
  364.         SEGDES MCHELM
  365.         ELSE
  366.       MRIGID=ISRAID
  367.       SEGDES MSOSTU
  368.       SEGACT MRIGID
  369.       NRIGEL=IRIGEL(/2)
  370.       IFOCHS = IFORIG
  371.       NDDL=0
  372.       SEGINI MNOC,IDEN,ICO,SINCO
  373.       ICMA=0
  374. C
  375. C    BOUCLE SUR LES POINTS DE LA SOUS STRUCTURE
  376. C
  377.       DO 250 IP=1,NPO
  378.       NDCP=0
  379. C
  380. C   BOUCLE SUR LES ZONES GEOMETRIQUES DE LA SOUS STRUCTURE
  381. C
  382.       DO 240 IAA=1,NRIGEL
  383.       MELEME=IRIGEL(1,IAA)
  384.       SEGACT MELEME
  385.       IF(ITYPEL.EQ.22) GOTO 235
  386.       NBELEM=NUM(/2)
  387.       NBPT=NUM(/1)
  388.       DO 5003 NBE=1,NBELEM
  389.       DO 150 NP=1,NBPT
  390.       IKI=NUM(NP,NBE)
  391.       NPEL=NP
  392.       IF(IKI.EQ.IGEO(IP)) GOTO 160
  393.   150 CONTINUE
  394.  5003 CONTINUE
  395.       GO TO 235
  396.   160 DESCR=IRIGEL(3,IAA)
  397.       SEGACT DESCR
  398.       NLIGRE=NOELEP(/1)
  399.       IC=0
  400.       ICC=0
  401. C
  402. C   BOUCLE SUR LES INCONNUES DE LA MATRICE DE RIGIDITE DE L'ELEMENT
  403. C
  404.       DO 230 I=1,NLIGRE
  405.       IF(NOELEP(I).NE.NPEL) GOTO 230
  406.       NOMCO=LISINC(I)
  407.       IF(NDDL.EQ.0) GOTO 180
  408. C
  409. C   BOUCLE SUR LES DDL TOTAUX DEJA CREES,ON DONNE UN NUMERO (NUCO) AU DD
  410. C
  411.       DO 170 ND=1,NDDL
  412.       NUCO=ND
  413.       IF(NOMCO.EQ.INCO(ND)) GOTO 190
  414.   170 CONTINUE
  415.   180 IC=IC+1
  416.       NUCO=NDDL+IC
  417.       INCO(NUCO)=NOMCO
  418.   190 CONTINUE
  419.       IF(NDCP.EQ.0) GOTO 210
  420. C
  421. C   BOUCLE SUR LES DDL DU PT DEJA CREES
  422. C
  423.       DO 200 NDC=1,NDCP
  424.       IF(NOMCO.EQ.NOCO(NDC,IP)) GOTO 220
  425.   200 CONTINUE
  426.   210 ICC=ICC+1
  427.       NDIC=NDCP+ICC
  428.       IF(NDIC.LE.ICCMAX) GOTO 215
  429. C  ***  A LA  NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1)
  430. C       TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE
  431.       CALL ERREUR(119)
  432.       SEGDES DESCR,MELEME,MRIGID,MSOSTU
  433.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO
  434.       GOTO 3
  435.   215 NOCO(NDIC,IP)=NOMCO
  436.       IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1
  437.       IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1)
  438.   220 CONTINUE
  439.   230 CONTINUE
  440.       SEGDES DESCR
  441.       NDDL=NDDL+IC
  442.       NDCP=NDCP+ICC
  443.   235 SEGDES MELEME
  444.   240 CONTINUE
  445.       ICO(IP)=NDCP
  446.       IF(NDCP.GT.ICMA) ICMA=NDCP
  447.   250 CONTINUE
  448.       SEGDES MRIGID
  449.       ENDIF
  450.       I1=NOCO(/2)
  451.       I2=NOCO(/3)
  452.       I3=IDEN(/1)
  453.       I4=ICO(/1)
  454.       I5=INCO(/2)
  455.       IF(IIMPI.EQ.2) WRITE(IOIMP,1004)((J,I,NOCO(I,J),I=1,I1),J=1,I2)
  456.       IF(IIMPI.EQ.2) WRITE(IOIMP,1005)(I,IDEN(I),I=1,I3)
  457.       IF(IIMPI.EQ.2) WRITE(IOIMP,1006)(I,ICO(I),I=1,I4)
  458.       IF(IIMPI.EQ.2) WRITE(IOIMP,1007)(I,INCO(I),I=1,I5)
  459.  1004 FORMAT(1X,' NOCO ',8(I4,1X,I4,1X,A4,1X))
  460.  1005 FORMAT(1X,' IDEN ',10(I4,1X,I4,1X))
  461.  1006 FORMAT(1X,' ICO  ',10(I4,1X,I4,1X))
  462.  1007 FORMAT(1X,' INCO ',10(I4,1X,A4,1X))
  463.       SEGSUP SINCO
  464. C
  465. C   **********     3     **********
  466. C
  467. C   COMPATIBILITE DES DONNEES CORRESPONDANT AUX DDL ET
  468. C   CREATION DU TABLEAU AUXILLIAIRE :
  469. C   VALE(IC,IP)  COEF POUR LE IC-IEME DDL DU IP-IEME PT
  470. C
  471.       IKIMA=ITRA2(/1)/2
  472.       ICMAX=ICMA
  473.       SEGINI MVAL
  474. C
  475. C   BOUCLE SUR LES POINTS DE LA SOUS-STRUCTURE
  476. C
  477.       DO 290 IP=1,NPO
  478.       NDCP=ICO(IP)
  479.       DO 255 IC=1,ICMAX
  480.       VALE(IC,IP)=0.
  481.   255 CONTINUE
  482. C
  483. C   RECHERCHE DU(ES) DDL DE LIAISON DU PT
  484. C   ON PARCOURS LE TABLEAU ITRA2
  485. C
  486.       DO 280 IKI=1,IKIMA
  487.       IT=2*(IKI-1)
  488.       IKIN=ITRA2(IT+1)
  489.       IF(IKIN.NE.IP) GOTO 280
  490.       WRITE (NOMCO,FMT='(A4)') ITRA2(IT+2)
  491. C
  492. C   BOUCLE SUR LES DDL DU PT
  493. C
  494.       DO 260 IC=1,NDCP
  495.         ICC=IC
  496.         IF(NOMCO.EQ.NOCO(IC,IP)) GOTO 270
  497.   260 CONTINUE
  498. C  *** LE DDL N'EXISTE PAS
  499.       INTERR(1)=MSOSTU
  500.       MOTERR=NOMCO
  501.       CALL ERREUR(118)
  502.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MVAL,MNOC,ICO,IDEN
  503.       GOTO 3
  504.   270 VALE(ICC,IP)=RCOEF(IKI)
  505.   280 CONTINUE
  506.   290 CONTINUE
  507.       SEGSUP ITRA2,RCOEF
  508.       I1=VALE(/1)
  509.       I2=VALE(/2)
  510.       IF(IIMPI.EQ.2) WRITE(IOIMP,1008)((J,I,VALE(I,J),I=1,I1),J=1,I2)
  511.  1008 FORMAT(1X,' VALE ',5(I4,1X,I4,1X,1PE12.5,1X))
  512. C
  513. C    **********     4     **********
  514. C
  515.       SEGINI ITRA4
  516.       DO 330 IP=1,NPO
  517.       IA=IDEN(IP)
  518.       IF(IA.EQ.0) GOTO 330
  519.       SEGINI ITRA3
  520. C
  521. C    CREATION DES MSOUPO DU CHAMPOINT    (ITRA4)
  522. C    RECHERCHE DES PTS AYANT LES MEMES DDDL   (ITRA3)
  523. C
  524.       DO 300 IPP=IP,NPO
  525.       IF(IA.NE.IDEN(IPP)) GOTO 300
  526.       ITRA3(**)=IPP
  527.       IDEN(IPP)=0
  528.   300 CONTINUE
  529.       NC=ICO(IP)
  530.   305 SEGINI MSOUPO
  531.       ITRA4(**)=MSOUPO
  532.       NBSOUS=0
  533.       NBREF=0
  534.       NBNN=1
  535.       NBELEM=ITRA3(/1)
  536.       SEGINI MELEME
  537.       IGEOC=MELEME
  538.       ITYPEL=1
  539.       N=NBELEM
  540.       SEGINI MPOVAL
  541.       IPOVAL=MPOVAL
  542.       DO 310 IC=1,NC
  543.       NOCOMP(IC)=NOCO(IC,IP)
  544.       IF(IIMPI.EQ.2) WRITE(IOIMP,308) IC, NOCOMP(IC)
  545.   308 FORMAT(4X,'NOCOMP(',I4,')=',A8)
  546.   310 CONTINUE
  547.       DO 5004 NBE=1,NBELEM
  548.       IPP=ITRA3(NBE)
  549.       NUM(1,NBE)=IGEO(IPP)
  550.       DO 320 IC=1,NC
  551.       DO 315 ICC=1,NC
  552.       IF(NOCO(ICC,IPP).EQ.NOCOMP(IC)) GOTO 317
  553.   315 CONTINUE
  554.   317 VPOCHA(NBE,IC)=VALE(IC,IPP)
  555.   320 CONTINUE
  556.  5004 CONTINUE
  557.       SEGDES MELEME,MPOVAL,MSOUPO
  558.       SEGSUP ITRA3
  559.   330 CONTINUE
  560.       SEGSUP IDEN,ICO,IGEO,MNOC,MVAL
  561.       NSOUPO=ITRA4(/1)
  562.       NAT=1
  563.       SEGINI MCHPOI
  564.       MCHPOI.MOCHDE = ' CHPOINT cree par JONCTION'
  565.       MCHPOI.MTYPOI = '        '
  566.       MCHPOI.IFOPOI = IFOCHS
  567.       DO 340 NS=1,NSOUPO
  568.       IPCHP(NS)=ITRA4(NS)
  569.   340 CONTINUE
  570.       SEGDES MCHPOI
  571.       SEGSUP ITRA4
  572. C
  573. C    **********           **********
  574. C
  575.       ITRA5(**)=MSOSTU
  576.       ITRA5(**)=MCHPOI
  577.   350 CONTINUE
  578. C
  579. C   CREATION DU MJONCT
  580. C
  581.   355 N=ITRA5(/1)/2
  582.       SEGINI MJONCT
  583.       IF(IMASS.EQ.1) THEN
  584.         MJOTYP=MOMAS(1)
  585.       ELSE
  586.         MJOTYP='MECA'
  587.       ENDIF
  588.       MJODDL='LX'
  589.       NBNO=nbpts
  590.       XCOOR(**)=0.
  591.       XCOOR(**)=0.
  592.       IF(IDIM.EQ.3) XCOOR(**)=0.
  593.       XCOOR(**)=0.
  594.       nbpts=nbpts+1
  595.       NBNN=1
  596.       NBELEM=1
  597.       NBREF=0
  598.       NBSOUS=0
  599.       SEGINI MELEME
  600.       ITYPEL=1
  601.       NUM(1,1)=NBNO+1
  602.       SEGDES MELEME
  603.       MJOPOI=MELEME
  604.       MJPOI=NBNO+1
  605.       DO 360 NN=1,N
  606.       NNN=2*NN
  607.       ISTRJO(NN)=ITRA5(NNN-1)
  608.       IPCHJO(NN)=ITRA5(NNN)
  609.   360 CONTINUE
  610.       SEGSUP ITRA5
  611.       SEGDES MJONCT
  612. C
  613. C   REMPLISSAGE DU MSOUMA
  614. C
  615.       IATREL(NNNN)=MJONCT
  616.       IF (IIMPI.EQ.2) WRITE (IOIMP,518) NNNN,IATREL(NNNN)
  617.   518 FORMAT(5X,'IATREL(',I4,')=',I8)
  618.   520 CONTINUE
  619.       SEGDES MSOUMA
  620. C
  621. C     CREATION DU MATTAC
  622. C
  623.       N=1
  624.       SEGINI MATTAC
  625.       LISATT(1)=MSOUMA
  626.       CALL ECROBJ('ATTACHE ',MATTAC)
  627.       SEGDES MATTAC
  628.       SEGSUP ITRA1
  629.  
  630. c      RETURN
  631.       END
  632.  
  633.  
  634.  
  635.  

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