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    FANDEUR   22/03/01    21:15:05     11301          
  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 2150 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. C           LE POINT N'APPARTIENT PAS A LA ZONE:SORTIR
  294.                 GO TO 2235
  295.  2160          CONTINUE
  296.                 SEGACT MCHAML
  297.                 NNINCO=NOMCHE(/2)
  298.                 IC=0
  299.                 ICC=0
  300. C
  301. C ********* BOUCLE SUR TOUS LES CHAMPS POSSIBLES
  302. C
  303.                 DO 2225 NN=1,NNINCO
  304. C
  305. C ********* RECHERCHE DU MOT"DEPLACEMENT"OU"FORCE"
  306. C
  307.       LDPROD=LDD+2*LDU
  308.       IF (IIMPI.EQ.2) WRITE(IOIMP,2165) LDPROD
  309.  2165 FORMAT(5X,'LDPROD=',I2)
  310.                       NCP=NN
  311.                       DO 2220 NCP1=NCP,NCP
  312.                          NOMCO=NOMCHE(NCP1)
  313. C
  314. C ****LE DEGRE DE LIB NOMCO EXISTE-T-IL DEJA DANS LES DDL CREES ?
  315. C
  316.                          IF(NDDL.EQ.0) GO TO 2180
  317.                          DO 2170 ND=1,NDDL
  318.                               NUCO=ND
  319.                               IF(NOMCO.EQ.INCO(ND)) GO TO 2190
  320.  2170                    CONTINUE
  321.  2180                 IC=IC+1
  322.                       NUCO=NDDL+IC
  323.                       INCO(NUCO)=NOMCO
  324.  2190                 CONTINUE
  325. C
  326. C ********LE DEGRE DE LIB NOMCO EXISTE-T-IL DANS LES DDL CREES POUR
  327. C             LE POINT COURANT IGEO(IP)
  328. C
  329.                       IF(NDCP.EQ.0)GO TO 2210
  330.                       DO 2200 NDC=1,NDCP
  331.                           IF(NOMCO.EQ.NOCO(NDC,IP)) GO TO 2220
  332.  2200                 CONTINUE
  333.  2210                 ICC=ICC+1
  334.                       NDIC=NDCP+ICC
  335.                       IF(IIMPI.EQ.2) WRITE(IOIMP,2211) NOMCO
  336.  2211                 FORMAT(5X,'NOMCO=',A)
  337.                       IF(IIMPI.EQ.2) WRITE(IOIMP,2214) NDIC
  338.                       IF(NDIC.LE.ICCMAX) GO TO 2215
  339. C        ERREUR
  340. C       TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE
  341.       IF(IIMPI.EQ.2) WRITE (IOIMP,2214) NDIC
  342.  2214 FORMAT(10X,'NDIC=',I4)
  343.       SEGDES MELEME
  344.       CALL ERREUR(119)
  345.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO
  346.       GOTO 3
  347.  2215                 NOCO(NDIC,IP)=NOMCO
  348. C  ***  A LA  NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1)
  349.                       IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1
  350.                       IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1)
  351.  2220                 CONTINUE
  352.  2225                 CONTINUE
  353.  2230           CONTINUE
  354.                 NDDL=NDDL+IC
  355.                 NDCP=NDCP+ICC
  356.  2235           CONTINUE
  357.                 SEGDES MELEME
  358.                 SEGDES MCHAML
  359.  2240      CONTINUE
  360.            ICO(IP)=NDCP
  361.            IF(NDCP.GT.ICMA) ICMA=NDCP
  362.  2250   CONTINUE
  363.         SEGDES MCHELM
  364.         ELSE
  365.       MRIGID=ISRAID
  366.       SEGDES MSOSTU
  367.       SEGACT MRIGID
  368.       NRIGEL=IRIGEL(/2)
  369.       IFOCHS = IFORIG
  370.       NDDL=0
  371.       SEGINI MNOC,IDEN,ICO,SINCO
  372.       ICMA=0
  373. C
  374. C    BOUCLE SUR LES POINTS DE LA SOUS STRUCTURE
  375. C
  376.       DO 250 IP=1,NPO
  377.       NDCP=0
  378. C
  379. C   BOUCLE SUR LES ZONES GEOMETRIQUES DE LA SOUS STRUCTURE
  380. C
  381.       DO 240 IAA=1,NRIGEL
  382.       MELEME=IRIGEL(1,IAA)
  383.       SEGACT MELEME
  384.       IF(ITYPEL.EQ.22) GOTO 235
  385.       NBELEM=NUM(/2)
  386.       NBPT=NUM(/1)
  387.       DO 150 NBE=1,NBELEM
  388.       DO 150 NP=1,NBPT
  389.       IKI=NUM(NP,NBE)
  390.       NPEL=NP
  391.       IF(IKI.EQ.IGEO(IP)) GOTO 160
  392.   150 CONTINUE
  393.       GO TO 235
  394.   160 DESCR=IRIGEL(3,IAA)
  395.       SEGACT DESCR
  396.       NLIGRE=NOELEP(/1)
  397.       IC=0
  398.       ICC=0
  399. C
  400. C   BOUCLE SUR LES INCONNUES DE LA MATRICE DE RIGIDITE DE L'ELEMENT
  401. C
  402.       DO 230 I=1,NLIGRE
  403.       IF(NOELEP(I).NE.NPEL) GOTO 230
  404.       NOMCO=LISINC(I)
  405.       IF(NDDL.EQ.0) GOTO 180
  406. C
  407. C   BOUCLE SUR LES DDL TOTAUX DEJA CREES,ON DONNE UN NUMERO (NUCO) AU DD
  408. C
  409.       DO 170 ND=1,NDDL
  410.       NUCO=ND
  411.       IF(NOMCO.EQ.INCO(ND)) GOTO 190
  412.   170 CONTINUE
  413.   180 IC=IC+1
  414.       NUCO=NDDL+IC
  415.       INCO(NUCO)=NOMCO
  416.   190 CONTINUE
  417.       IF(NDCP.EQ.0) GOTO 210
  418. C
  419. C   BOUCLE SUR LES DDL DU PT DEJA CREES
  420. C
  421.       DO 200 NDC=1,NDCP
  422.       IF(NOMCO.EQ.NOCO(NDC,IP)) GOTO 220
  423.   200 CONTINUE
  424.   210 ICC=ICC+1
  425.       NDIC=NDCP+ICC
  426.       IF(NDIC.LE.ICCMAX) GOTO 215
  427. C  ***  A LA  NUCO-IEME COMPOSANTE ON ASSOCIE LE NB 2**(NUCO-1)
  428. C       TROP DE COMPOSANTES,ON DEPASSE LA CAPACITE DE LA MACHINE
  429.       CALL ERREUR(119)
  430.       SEGDES DESCR,MELEME,MRIGID,MSOSTU
  431.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MNOC,IDEN,ICO,SINCO
  432.       GOTO 3
  433.   215 NOCO(NDIC,IP)=NOMCO
  434.       IF(NUCO.EQ.1) IDEN(IP)=IDEN(IP)+1
  435.       IF(NUCO.NE.1) IDEN(IP)=IDEN(IP)+2**(NUCO-1)
  436.   220 CONTINUE
  437.   230 CONTINUE
  438.       SEGDES DESCR
  439.       NDDL=NDDL+IC
  440.       NDCP=NDCP+ICC
  441.   235 SEGDES MELEME
  442.   240 CONTINUE
  443.       ICO(IP)=NDCP
  444.       IF(NDCP.GT.ICMA) ICMA=NDCP
  445.   250 CONTINUE
  446.       SEGDES MRIGID
  447.       ENDIF
  448.       I1=NOCO(/2)
  449.       I2=NOCO(/3)
  450.       I3=IDEN(/1)
  451.       I4=ICO(/1)
  452.       I5=INCO(/2)
  453.       IF(IIMPI.EQ.2) WRITE(IOIMP,1004)((J,I,NOCO(I,J),I=1,I1),J=1,I2)
  454.       IF(IIMPI.EQ.2) WRITE(IOIMP,1005)(I,IDEN(I),I=1,I3)
  455.       IF(IIMPI.EQ.2) WRITE(IOIMP,1006)(I,ICO(I),I=1,I4)
  456.       IF(IIMPI.EQ.2) WRITE(IOIMP,1007)(I,INCO(I),I=1,I5)
  457.  1004 FORMAT(1X,' NOCO ',8(I4,1X,I4,1X,A4,1X))
  458.  1005 FORMAT(1X,' IDEN ',10(I4,1X,I4,1X))
  459.  1006 FORMAT(1X,' ICO  ',10(I4,1X,I4,1X))
  460.  1007 FORMAT(1X,' INCO ',10(I4,1X,A4,1X))
  461.       SEGSUP SINCO
  462. C
  463. C   **********     3     **********
  464. C
  465. C   COMPATIBILITE DES DONNEES CORRESPONDANT AUX DDL ET
  466. C   CREATION DU TABLEAU AUXILLIAIRE :
  467. C   VALE(IC,IP)  COEF POUR LE IC-IEME DDL DU IP-IEME PT
  468. C
  469.       IKIMA=ITRA2(/1)/2
  470.       ICMAX=ICMA
  471.       SEGINI MVAL
  472. C
  473. C   BOUCLE SUR LES POINTS DE LA SOUS-STRUCTURE
  474. C
  475.       DO 290 IP=1,NPO
  476.       NDCP=ICO(IP)
  477.       DO 255 IC=1,ICMAX
  478.       VALE(IC,IP)=0.
  479.   255 CONTINUE
  480. C
  481. C   RECHERCHE DU(ES) DDL DE LIAISON DU PT
  482. C   ON PARCOURS LE TABLEAU ITRA2
  483. C
  484.       DO 280 IKI=1,IKIMA
  485.       IT=2*(IKI-1)
  486.       IKIN=ITRA2(IT+1)
  487.       IF(IKIN.NE.IP) GOTO 280
  488.       WRITE (NOMCO,FMT='(A4)') ITRA2(IT+2)
  489. C
  490. C   BOUCLE SUR LES DDL DU PT
  491. C
  492.       DO 260 IC=1,NDCP
  493.         ICC=IC
  494.         IF(NOMCO.EQ.NOCO(IC,IP)) GOTO 270
  495.   260 CONTINUE
  496. C  *** LE DDL N'EXISTE PAS
  497.       INTERR(1)=MSOSTU
  498.       MOTERR=NOMCO
  499.       CALL ERREUR(118)
  500.       SEGSUP ITRA2,ITRA5,IGEO,RCOEF,MVAL,MNOC,ICO,IDEN
  501.       GOTO 3
  502.   270 VALE(ICC,IP)=RCOEF(IKI)
  503.   280 CONTINUE
  504.   290 CONTINUE
  505.       SEGSUP ITRA2,RCOEF
  506.       I1=VALE(/1)
  507.       I2=VALE(/2)
  508.       IF(IIMPI.EQ.2) WRITE(IOIMP,1008)((J,I,VALE(I,J),I=1,I1),J=1,I2)
  509.  1008 FORMAT(1X,' VALE ',5(I4,1X,I4,1X,1PE12.5,1X))
  510. C
  511. C    **********     4     **********
  512. C
  513.       SEGINI ITRA4
  514.       DO 330 IP=1,NPO
  515.       IA=IDEN(IP)
  516.       IF(IA.EQ.0) GOTO 330
  517.       SEGINI ITRA3
  518. C
  519. C    CREATION DES MSOUPO DU CHAMPOINT    (ITRA4)
  520. C    RECHERCHE DES PTS AYANT LES MEMES DDDL   (ITRA3)
  521. C
  522.       DO 300 IPP=IP,NPO
  523.       IF(IA.NE.IDEN(IPP)) GOTO 300
  524.       ITRA3(**)=IPP
  525.       IDEN(IPP)=0
  526.   300 CONTINUE
  527.       NC=ICO(IP)
  528.   305 SEGINI MSOUPO
  529.       ITRA4(**)=MSOUPO
  530.       NBSOUS=0
  531.       NBREF=0
  532.       NBNN=1
  533.       NBELEM=ITRA3(/1)
  534.       SEGINI MELEME
  535.       IGEOC=MELEME
  536.       ITYPEL=1
  537.       N=NBELEM
  538.       SEGINI MPOVAL
  539.       IPOVAL=MPOVAL
  540.       DO 310 IC=1,NC
  541.       NOCOMP(IC)=NOCO(IC,IP)
  542.       IF(IIMPI.EQ.2) WRITE(IOIMP,308) IC, NOCOMP(IC)
  543.   308 FORMAT(4X,'NOCOMP(',I4,')=',A8)
  544.   310 CONTINUE
  545.       DO 320 NBE=1,NBELEM
  546.       IPP=ITRA3(NBE)
  547.       NUM(1,NBE)=IGEO(IPP)
  548.       DO 320 IC=1,NC
  549.       DO 315 ICC=1,NC
  550.       IF(NOCO(ICC,IPP).EQ.NOCOMP(IC)) GOTO 317
  551.   315 CONTINUE
  552.   317 VPOCHA(NBE,IC)=VALE(IC,IPP)
  553.   320 CONTINUE
  554.       SEGDES MELEME,MPOVAL,MSOUPO
  555.       SEGSUP ITRA3
  556.   330 CONTINUE
  557.       SEGSUP IDEN,ICO,IGEO,MNOC,MVAL
  558.       NSOUPO=ITRA4(/1)
  559.       NAT=1
  560.       SEGINI MCHPOI
  561.       MCHPOI.MOCHDE = ' CHPOINT cree par JONCTION'
  562.       MCHPOI.MTYPOI = '        '
  563.       MCHPOI.IFOPOI = IFOCHS
  564.       DO 340 NS=1,NSOUPO
  565.       IPCHP(NS)=ITRA4(NS)
  566.   340 CONTINUE
  567.       SEGDES MCHPOI
  568.       SEGSUP ITRA4
  569. C
  570. C    **********           **********
  571. C
  572.       ITRA5(**)=MSOSTU
  573.       ITRA5(**)=MCHPOI
  574.   350 CONTINUE
  575. C
  576. C   CREATION DU MJONCT
  577. C
  578.   355 N=ITRA5(/1)/2
  579.       SEGINI MJONCT
  580.       IF(IMASS.EQ.1) THEN
  581.         MJOTYP=MOMAS(1)
  582.       ELSE
  583.         MJOTYP='MECA'
  584.       ENDIF
  585.       MJODDL='LX'
  586.       NBNO=nbpts
  587.       XCOOR(**)=0.
  588.       XCOOR(**)=0.
  589.       IF(IDIM.EQ.3) XCOOR(**)=0.
  590.       XCOOR(**)=0.
  591.       nbpts=nbpts+1
  592.       NBNN=1
  593.       NBELEM=1
  594.       NBREF=0
  595.       NBSOUS=0
  596.       SEGINI MELEME
  597.       ITYPEL=1
  598.       NUM(1,1)=NBNO+1
  599.       SEGDES MELEME
  600.       MJOPOI=MELEME
  601.       MJPOI=NBNO+1
  602.       DO 360 NN=1,N
  603.       NNN=2*NN
  604.       ISTRJO(NN)=ITRA5(NNN-1)
  605.       IPCHJO(NN)=ITRA5(NNN)
  606.   360 CONTINUE
  607.       SEGSUP ITRA5
  608.       SEGDES MJONCT
  609. C
  610. C   REMPLISSAGE DU MSOUMA
  611. C
  612.       IATREL(NNNN)=MJONCT
  613.       IF (IIMPI.EQ.2) WRITE (IOIMP,518) NNNN,IATREL(NNNN)
  614.   518 FORMAT(5X,'IATREL(',I4,')=',I8)
  615.   520 CONTINUE
  616.       SEGDES MSOUMA
  617. C
  618. C     CREATION DU MATTAC
  619. C
  620.       N=1
  621.       SEGINI MATTAC
  622.       LISATT(1)=MSOUMA
  623.       CALL ECROBJ('ATTACHE ',MATTAC)
  624.       SEGDES MATTAC
  625.       SEGSUP ITRA1
  626.  
  627. c      RETURN
  628.       END
  629.  
  630.  
  631.  

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