Télécharger la plaquette Cast3M


fr en

Télécharger assem4.eso

Retour à la liste

Numérotation des lignes : 

assem4

  1. C ASSEM4    SOURCE    PV090527  24/03/03    21:15:02     11858          
  2.       SUBROUTINE ASSEM4(IPOIRI,NOINC,SNOMIN,NOMAI,MMATRX,
  3.      #   INUINY,ITOPOY,INCTRY,IITOPY,NBNNMA,NLIGRA,SNTT,SNTO,DES1)
  4.  
  5. ** CETTE SUBROUTINE EFFECTUE LA PREPARATION A L'ASSEMBLAGE DANS LE CAS DU CALCUL DU
  6. **  SUPER-ELEMENT
  7.  
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.       CHARACTER*4 CMOT
  11.  
  12.  
  13. -INC PPARAM
  14. -INC CCOPTIO
  15. -INC SMELEME
  16. -INC SMCOORD
  17. -INC SMRIGID
  18. -INC SMMATRI
  19. -INC CCREEL
  20.  
  21.       SEGMENT,IMIN(NNOE)
  22.       SEGMENT,ICPR(nbpts)
  23.       SEGMENT,INUINV(NNGLOB)
  24.       SEGMENT,INUIN2(2*NNOE)
  25.       SEGMENT,ITOPO(IENNO)
  26.       SEGMENT,IITOP(NNOE+1)
  27.       SEGMENT,INCTRR(NIRI)
  28.       SEGMENT,INCTRA(NLIGRE)
  29.       SEGMENT DIATMP(maxinc,NNOE)
  30.       segment strv
  31.        integer itrv1(maxinc)
  32.        integer itrv2(maxinc)
  33.        real*8 dtrv1(maxinc)
  34.        real*8 dtrv2(maxinc)
  35.       endsegment
  36. C
  37. C  ****  CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG
  38. C  ****  IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE.
  39. C
  40. C
  41. C  ****   MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD
  42. C
  43. C  ****   IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN
  44. C                    IEME POSITION DANS ITOPO
  45. C  ****   ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA
  46. C         ITOPO(I+1)=M  MATRICE EST LE LIEME  DE L'OBJET GEOMETRIE
  47. C                       DEFINI PAR LE POINTEUR M
  48. C  ****  INUINV(I)=J    J EST LE NOUVEAU NUMERO DU NOEUD I
  49. C
  50.  
  51. **  SEGMENTS DE TRAVAIL
  52.  
  53.       SEGMENT NOMAI(nbpts)
  54.       SEGMENT NOINC(NNIN,ITA)
  55.       SEGMENT SNOMIN
  56.         CHARACTER*(LOCOMP) NOMIN(M)
  57.       ENDSEGMENT
  58.       SEGMENT SNTO
  59.         INTEGER NTOTMA(NN)
  60.       ENDSEGMENT
  61. C
  62.       SEGMENT SNTT
  63.         INTEGER NTTMAI(NN)
  64.       ENDSEGMENT
  65. C
  66.       SEGMENT ILOCAL(NBNUM)
  67. C
  68. **   NOMAI(I)<>0 SI LE NOEUD I EST MAITRE (I=N° ABSOLU)
  69. C
  70. **   NOINC(I,J)=1 SI L'INCONNUE I EXISTE POUR LE NOEUD J (J=N° LOCAL)
  71. C
  72. **   NOMIN(I)= INCO : L'INCONNUE N°I EST L'INCONNUE DE NOM 'INCO'
  73. **                 CE SEGMENT NE CONTIENT QUE LES INCONNUES MAITRESSES
  74. **   NTOTMA : SEGMENT DES NOEUDS MAITRES POUR LESQUELS TOUTES LES INCONNUES
  75. **            SONT MAITRESSES
  76. **   NTTMAI : SEGMENT DES NOEUDS MAITRES QUI N'ONT PAS TOUTES LEURS INCONNUES
  77. **            MAITRESSES
  78. **   ILOCAL : SEGMENT DES NUMEROS LOCAUX
  79.  
  80.  
  81. *      DATA MOALFA/'ALFA'/
  82.        CHARACTER*4 CNOHA
  83.        integer*4 noha
  84.        equivalence (cnoha,noha)
  85.        DATA CNOHA/'NOHA'/
  86.       DATA IPOIN/1/
  87.  
  88.       NNGLOB=nbpts
  89.  
  90.       MRIGID=IPOIRI
  91.       SEGACT,MRIGID
  92.  
  93.       NNVA=IRIGEL(/2)
  94.       NIRI=NNVA
  95.       SEGINI,INCTRR
  96.       MVA=IRIGEL(/1)
  97.       MELEME=IRIGEL(1,1)
  98.       SEGACT,MELEME
  99.       IF(ITYPEL.NE.27) GO TO 801
  100.       SEGDES MELEME
  101. C
  102. C  **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS
  103. C  **** DANS ICPR
  104. C
  105.       SEGINI,INUINV,ICPR
  106.       IKI=0
  107.       DO 700 I=1,NNVA
  108.       MELEME=IRIGEL(1,I)
  109.       SEGACT,MELEME
  110.       NBNN=NUM(/1)
  111.       NBELEM=NUM(/2)
  112.       DO I1=1,NBELEM
  113.       DO 701 I2=1,NBNN
  114.       IP1=NUM(I2,I1)
  115.       IF(ICPR(IP1).NE.0) GO TO 701
  116.       IKI=IKI+1
  117.       ICPR(IP1)=IKI
  118.  701  CONTINUE
  119.       enddo
  120.       SEGDES MELEME
  121.  700  CONTINUE
  122. C
  123. C  **** FABRICATION DU TABLEAU INUINV
  124. C  **** ON MET LES POINTS QUI ONT POUR INCONNUE ALFA EN TETE
  125. C
  126.       NNOE=IKI
  127.       NALFA=0
  128.       NBETA=0
  129.       DO 710 I=1,NNVA
  130.       MELEME=IRIGEL(1,I)
  131.       DESCR =IRIGEL(3,I)
  132.       SEGACT,MELEME,DESCR
  133.       NBNN=NUM(/1)
  134.       NBELEM=NUM(/2)
  135.       NLIGRE=LISINC(/2)
  136.       DO I1=1,NBELEM
  137.       DO 711 I2=1,NBNN
  138.       IP1=NUM(I2,I1)
  139.       IF(ICPR(IP1).EQ.0) GO TO 711
  140.  715  CONTINUE
  141.       NBETA=NBETA+1
  142.       IKI=NNOE-NBETA+1
  143.  716  CONTINUE
  144.       INUINV(IP1)=IKI
  145.       ICPR(IP1)=0
  146.  711  CONTINUE
  147.       enddo
  148.       SEGDES MELEME,DESCR
  149.  710  CONTINUE
  150.       SEGSUP,ICPR
  151.       ICDOUR=NNOE
  152.       GO TO 800
  153. C
  154. C  ****  ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  155. C  ****  GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS
  156. C  ****  GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI
  157. C  ****  FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  158. C  ****  NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  159. C  ****  LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  160. C  ****  DE LA MATRICE, ETC...
  161. C
  162.  
  163.  801  CONTINUE
  164.  
  165.       NUMDEB=INT(nbpts)
  166.       MAXNUM=NUMDEB
  167.  
  168.       NBNUM=NUMDEB
  169.       SEGINI,ILOCAL
  170.  
  171. **  NUMEROTATION LOCALE DE TOUS LES NOEUDS
  172.       IKOU=0
  173.       SEGACT NOMAI
  174.       SEGADJ NOMAI
  175. ***   write (6,*) ' dimension de nomai ',nomai(/1),nnglob
  176.       DO 50 I0=1,NNVA
  177.          MELEME=IRIGEL(1,I0)
  178.          SEGACT,MELEME
  179.          DO I2=1,NUM(/2)
  180.           DO 51 I1=1,NUM(/1)
  181.             IJ=NUM(I1,I2)
  182.             IF (ILOCAL(IJ).NE.0.or.nomai(ij).ne.0)  GOTO 51
  183.             IKOU=IKOU+1
  184.             ILOCAL(IJ)=IKOU
  185.   51     CONTINUE
  186.          enddo
  187.         SEGDES MELEME
  188.   50  CONTINUE
  189.       NNOE=IKOU
  190.       DO 52 I=1,NOMAI(/1)
  191.         IF(NOMAI(I).NE.0.AND.ILOCAL(I).EQ.0) THEN
  192.           NNOE=NNOE+1
  193.           ILOCAL(I)=ikou+nomai(i)
  194.         ENDIF
  195.  52   CONTINUE
  196.       SEGDES NOMAI
  197. C
  198. C  RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  199. C  DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  200. C
  201.       DO 230 IRI=1,NNVA
  202.       IHARIR=IRIGEL(5,IRI)
  203.       IF(IHARIR.NE.NOHA) THEN
  204.         IARDEF = IHARIR
  205.         GO TO 231
  206.       ENDIF
  207.   230 CONTINUE
  208.       CALL ERREUR ( 21)
  209.       RETURN
  210.   231 CONTINUE
  211.       DO 232 IRI=1,NNVA
  212.       IF( IRIGEL(5,IRI).EQ.NOHA) GO TO 232
  213.       IF( IRIGEL(5,IRI).EQ.IARDEF ) GO TO 232
  214.       CALL ERREUR (21)
  215.       RETURN
  216.  232  CONTINUE
  217. C
  218. C  ****  RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  219. C
  220.       SEGINI,MIDUA
  221.       SEGINI,MIMIK
  222.       SEGINI,MHARK
  223.       DESCR=IRIGEL(3,1)
  224.       SEGACT,DESCR
  225.       IMIK(**)=LISINC(1)
  226.       IAAR=IRIGEL(5,1)
  227.       IF(IAAR.EQ.NOHA) IAAR = IARDEF
  228.       IHAR(**)= IAAR
  229.       IDUA(**)=LISDUA(1)
  230.       MAXINC=1
  231.       DO 323 IRI=1,NNVA
  232.       DESCR=IRIGEL(3,IRI)
  233.       IHARIR=IRIGEL(5,IRI)
  234.       IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  235.       SEGACT,DESCR
  236.       NLIGRE=LISINC(/2)
  237.       DO 326 I=1,NLIGRE
  238.       DO 324 J=1,MAXINC
  239.       IF(IMIK(J).NE.LISINC(I)) GO TO 324
  240.       IF(IHAR(J).EQ.IHARIR) GO TO 326
  241.   324 CONTINUE
  242.       MAXINC=MAXINC+1
  243.       IHAR(**)=IHARIR
  244.       IMIK(**)=LISINC(I)
  245.       IDUA(**)=LISDUA(I)
  246.   326 CONTINUE
  247.       SEGDES,DESCR
  248.   323 CONTINUE
  249.       NDUA=IDUA(/2)
  250.  
  251. C
  252. C  **** INITIALISATION DE INCPOS ET DE INCTRA.
  253. C
  254.       MAXI=MAXINC
  255.       SEGINI DIATMP,strv
  256.       SEGINI,MINCPO
  257.       DO 329 IRI=1,NNVA
  258.        DESCR=IRIGEL(3,IRI)
  259.        IHARIR=IRIGEL(5,IRI)
  260.        IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  261.        SEGACT,DESCR
  262.        MELEME=IRIGEL(1,IRI)
  263.        SEGACT,MELEME
  264.        NLIGRE=LISINC(/2)
  265.        SEGINI,INCTRA
  266.        INCTRR(IRI)=INCTRA
  267.        N2=NUM(/2)
  268.        IADS=nbpts
  269.        xmatri=irigel(4,iri)
  270.        segact xmatri
  271.        DO 334 J=1,NLIGRE
  272.         DO 333 K=1,MAXINC
  273.          IF(LISINC(J).NE.IMIK(K)) GO TO 333
  274.          IF(IHAR(K).EQ.IHARIR) GO TO 332
  275.   333   CONTINUE
  276.   332   CONTINUE
  277.         INCTRA(J)=K
  278.         DO 331 I=1,N2
  279.          IJ=ILOCAL(NUM(NOELEP(J),I))
  280.          INCPO(K,IJ)=1
  281.          diatmp(k,ij)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
  282.   331    continue
  283.   334  CONTINUE
  284.        SEGDES,DESCR
  285.        SEGDES,INCTRA
  286.   329 CONTINUE
  287. C
  288.       SEGACT,SNOMIN
  289.       SEGACT,NOMAI
  290.       SEGACT,NOINC
  291.       DO 3301 I=1,NOMAI(/1)
  292.         IF(NOMAI(I).EQ.0) GOTO 3301
  293.         N1=NOMAI(I)
  294.         DO 3302 J=1,NOMIN(/2)
  295.           IF(NOINC(J,N1).EQ.0) GOTO 3302
  296.            DO 3303 K=1,IMIK(/2)
  297.             IF(NOMIN(J).EQ.IMIK(K)) GO TO 3304
  298.  3303     CONTINUE
  299.  3304     CONTINUE
  300.           INCPO(K,ILOCAL(I))=1
  301.  3302   CONTINUE
  302.  3301 CONTINUE
  303. C
  304. C
  305.       MAXPOD=MAXINC*NNOE+1
  306.       MAXPO=MAXPOD
  307.       NBNNMA=0
  308.       DO 299 I=1,INCPO(/1)
  309.         DO 2991 J=1,INCPO(/2)
  310.            NBNNMA=NBNNMA+INCPO(I,J)
  311.  2991   CONTINUE
  312.  299  CONTINUE
  313. C
  314. C ** ON EFFECTUE UN TRI DES NOEUDS MAITRES POUR DISTINGUER LES NOEUDS
  315. C ** "TOTALEMENT MAITRES" DES NOEUDS "NON TOTALEMENT MAITRES"
  316. C
  317.       NLIGRA=0
  318.       DO 30 I=1,NOMAI(/1)
  319.         IF (NOMAI(I).EQ.0) GOTO 30
  320.  32     CONTINUE
  321.         NINCMA=0
  322.         NINC = 0
  323.         DO 33 J=1,INCPO(/1)
  324.           N2=J
  325.           IF (INCPO(J,ILOCAL(I)).NE.1) GOTO 33
  326.           NINC=NINC+1
  327.           DO 34 JJ=1,NOMIN(/2)
  328.             N3=JJ
  329.             IF (IMIK(J).EQ.NOMIN(JJ)) GOTO 35
  330. **          IF (IMIK(J).EQ.NOMIN(JJ).AND.IHAR(J).EQ.IHARMA(JJ)) GOTO 35
  331.  34       CONTINUE
  332.           GOTO 33
  333.  35       CONTINUE
  334.           IF (NOINC(N3,NOMAI(I)).EQ.1) THEN
  335.             INCPO(N2,ILOCAL(I))=MAXPOD
  336.             NINCMA=NINCMA+1
  337.             NLIGRA=NLIGRA+1
  338.             NBNNMA=NBNNMA-1
  339.           ENDIF
  340.  33     CONTINUE
  341.         IF(NINCMA.GT.0) THEN
  342.           IF(NINCMA.EQ.NINC) THEN
  343.              NTOTMA(**)=ILOCAL(I)
  344.              DO 3333 J=1,INCPO(/1)
  345.                 IF(INCPO(J,ILOCAL(I)).EQ.MAXPOD)
  346.      &             INCPO(J,ILOCAL(I))=1
  347.  3333        CONTINUE
  348.           ELSE
  349.             NTTMAI(**)=ILOCAL(I)
  350.           ENDIF
  351.         ENDIF
  352.  30   CONTINUE
  353.       NODDEB=NNOE
  354.       SEGDES NOINC
  355. C
  356. C  ****  ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  357. C  ****  GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA+1 OBJETS
  358. C  ****  GEOMETRIQUES ELEMENTAIRES. LE PREMIER SOUS-OBJET CONTIENT
  359. C  ****  LES NOEUDS TOTALEMENT MAITRES (S'IL Y EN A), QUI SERONT
  360. C  ****  PLACES EN FIN DE NUMEROTATION. ON APPELLE NUMOPT2 (OU NUMOPT)
  361. C  ****  QUI FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  362. C  ****  NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  363. C  ****  LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  364. C  ****  DE LA MATRICE, ETC...
  365. C
  366. C        on met d'abord en tete un point bidon pour etre coherent
  367. C        avec le precontionnement dans numopt
  368. C
  369. **     write(6,*) ' ntotma ',ntotma(/1)
  370. **     write(6,*) ' nttmai ',nttmai(/1)
  371.  
  372.  
  373.        IF(NTOTMA(/1).NE.0) THEN
  374.          NBNN=1
  375.          NBSOUS=0
  376.          NBREF=0
  377.          NBELEM=1
  378.          SEGINI,IPT5
  379.          IPT5.ITYPEL=28
  380.          DO 221 J=1,ILOCAL(/1)
  381.            IF (ILOCAL(J).EQ.NTOTMA(1))  GOTO 222
  382.  221     CONTINUE
  383.          CALL ERREUR(5)
  384.  222     CONTINUE
  385.          IPT5.NUM(1,1)=J
  386.          NBELEM=NTOTMA(/1)
  387.          SEGINI,IPT3
  388. *  en fait on n'utilisera pas ipt3 dans numop2
  389. *  contre performant + bug
  390.          IPT3.ITYPEL=28
  391.          DO 200 I=1,NTOTMA(/1)
  392.          DO 201 J=1,ILOCAL(/1)
  393.            IF (ILOCAL(J).EQ.NTOTMA(I))  GOTO 202
  394.  201     CONTINUE
  395.          CALL ERREUR(5)
  396.          RETURN
  397.  202     CONTINUE
  398.          IPT3.NUM(1,I)=J
  399.  200     CONTINUE
  400.  
  401.        ELSE
  402.  
  403.          IKK=1
  404.  722     CONTINUE
  405.          MELEME=IRIGEL(1,IKK)
  406.          SEGACT,MELEME
  407.          if (num(/2).eq.0) then
  408.          ikk=ikk+1
  409.          IF(IKK.LE.NNVA)  GO TO 722
  410.          write(6,*) 'assem4 ikk nnva',ikk,nnva
  411.          endif
  412.          DESCR=IRIGEL(3,IKK)
  413.          SEGACT,DESCR
  414.          NLIGRE=LISINC(/2)
  415.          DO 720 K=1,NLIGRE
  416.          IF(LISINC(K).NE.'LX  ') GO TO 721
  417.   720    CONTINUE
  418.          SEGDES,MELEME
  419.          SEGDES,DESCR
  420.          IKK=IKK+1
  421.          IF(IKK.LE.NNVA)  GO TO 722
  422.          DO 4862 I=1,NNVA
  423.          MELEME= IRIGEL(1,I)
  424.          SEGACT MELEME
  425. *        write(6,*) 'num en 420',num(/1),num(/2),itypel
  426.          if (num(/2).eq.0) goto 4862
  427.          IF(ITYPEL.EQ.49) THEN
  428.          DESCR=IRIGEL(3,I  )
  429.          SEGACT,DESCR
  430.          K = 3
  431.          GO TO 4863
  432.          ELSE
  433.          SEGDES MELEME
  434.          ENDIF
  435.  4862    CONTINUE
  436.          K=1
  437.          MELEME= IRIGEL(1,1)
  438.          DESCR= IRIGEL(3,1)
  439.          SEGACT MELEME,DESCR
  440. 4863     CONTINUE
  441.   721    IA=NOELEP(K)
  442.          I1=NUM(IA,1)
  443.          NBSOUS=0
  444.          NBNN=1
  445.          NBREF=0
  446.          NBELEM=1
  447.          SEGINI,IPT3
  448.          IPT3.ITYPEL=1
  449.          IPT3.NUM(1,1)=I1
  450.          ipt5=ipt3
  451.          SEGDES,MELEME,DESCR
  452.        ENDIF
  453.       SEGDES IPT3
  454.       NBSOUS=NNVA+2
  455.       NBREF=0
  456.       NBNN=0
  457.       NBELEM=0
  458.       SEGINI,IPT2
  459.       IPT2.LISOUS(1)=IPT5
  460.       IPT2.LISOUS(2)=IPT3
  461.       NOSOUS=3
  462.       DO 210 I=1,NNVA
  463.         IPT2.LISOUS(NOSOUS)=IRIGEL(1,I)
  464.         NOSOUS=NOSOUS+1
  465.  210  CONTINUE
  466.  
  467.       NNGLOB=ILOCAL(/1)
  468.       SEGINI,INUINV
  469.       DO 450 I=1,NNGLOB
  470.         INUINV(I)=ILOCAL(I)
  471.  450  CONTINUE
  472.  
  473.         CALL NUMOPT(IPT2,INUINV,NNOE)
  474.         segact inuinv*mod
  475.       IF(NTOTMA(/1).NE.0) THEN
  476. *  on remet les noeuds totalement maitre a la fin, ce que numopt ne fait
  477. *  pas
  478.       nbtmai=ntotma(/1)
  479.       segact ipt3
  480.       do i=1,nbtmai
  481. **     write(6,*) ' assem4 nnglob ',nnoe-ntotma(/1),
  482. **   >   inuinv(ipt3.num(1,i))
  483.         inuinv(ipt3.num(1,i))= inuinv(ipt3.num(1,i))+nnoe  
  484.       enddo
  485.       segini inuin2
  486.       do i=1,nnglob
  487.         if (inuinv(i).ne.0) inuin2(inuinv(i))=i
  488.       enddo
  489.       icour=0
  490.       do 803 i=1,2*nnoe  
  491.         if (inuin2(i).eq.0) goto 803
  492.         icour=icour+1
  493.         inuin2(icour)=inuin2(i)
  494.         if (i.ne.icour) inuin2(i)=0
  495.  803  continue
  496.       if(icour.gt.nnoe) call erreur(5)
  497.       do i=1,nnglob
  498.         inuinv(i)=0
  499.       enddo
  500.       do i=1,nnoe
  501.         if (inuin2(i).ne.0) inuinv(inuin2(i))=i
  502.       enddo
  503.       segsup inuin2
  504.       ENDIF
  505.  
  506.  
  507.  800  CONTINUE
  508.  
  509. **  ON APPLIQUE LA NOUVELLE NUMEROTATION A INCPO ET A NTTMAI
  510.  
  511.       SEGINI,MIPO1=MINCPO
  512.       DO 600 I=1,NNGLOB  
  513.         if (ilocal(i).eq.0.and.inuinv(i).ne.0) then       
  514.         write(6,*)  'i ilocal inuinv',i,ilocal(i),inuinv(i)
  515.         call erreur(5)
  516.         return
  517.         endif
  518.         if (ilocal(i).ne.0.and.inuinv(i).eq.0) then
  519.          write(6,*) 'i ilocal inuinv',i,ilocal(i),inuinv(i)
  520.         call erreur(5)
  521.         return
  522.         endif
  523.         IF (ILOCAL(I).EQ.0) GOTO 600
  524.         DO 610 II=1,MAXINC
  525.           INCPO(II,INUINV(I))=MIPO1.INCPO(II,ILOCAL(I))
  526.  610    CONTINUE
  527.  600  CONTINUE
  528.  
  529.       SEGSUP,MIPO1
  530.       DO 615 I=1,NTTMAI(/1)
  531.         DO 616 II=1,ILOCAL(/1)
  532.           IF (NTTMAI(I).EQ.ILOCAL(II)) THEN
  533.              NTTMAI(I)=INUINV(II)
  534.              GOTO 615
  535.           ENDIF
  536.  616    CONTINUE
  537.  615  CONTINUE
  538.  
  539.       DO 617 I=1,NTOTMA(/1)
  540.         DO 618 II=1,ILOCAL(/1)
  541.           IF (NTOTMA(I).EQ.ILOCAL(II)) THEN
  542.              NTOTMA(I)=INUINV(II)
  543.              GOTO 617
  544.           ENDIF
  545.  618    CONTINUE
  546.  617  CONTINUE
  547. C
  548. C  ****  CREATION D'UN OBJET GEOMETRIE (IPT1) QU'IL FAUDRA CHANGER EN CAS DE
  549. C  ****  RENUMEROTATION GENERALE. ON PROFITE DE LA BOUCLE POUR CREER LE
  550. C  ****  TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I (NU-
  551. C  ****  MEROTATION LOCALE).
  552. C
  553.       SEGINI,IMIN
  554.       NBSOUS=0
  555.       NBREF=0
  556.       NBNN=1
  557.       NBELEM=NNOE
  558.       SEGINI,IPT1
  559.       IPT1.ITYPEL=IPOIN
  560.       DO 316 IRI=1,NNVA
  561.       MELEME=IRIGEL(1,IRI)
  562.       SEGACT,MELEME
  563.       N1=NUM(/1)
  564.       N2=NUM(/2)
  565.       DO  I=1,N2
  566.       DO  J=1,N1
  567.       K=NUM(J,I)
  568.       M=INUINV(K)
  569.       IMIN(M)=IMIN(M)+1
  570.       IPT1.NUM(1,M)=K
  571.       enddo
  572.       enddo
  573.       SEGDES,MELEME
  574.   316 CONTINUE
  575.       DO 3161 I=1,NOMAI(/1)
  576.          IF(NOMAI(I).EQ.0) GO TO 3161
  577.          IPT1.NUM(1,INUINV(I))=I
  578.  3161 CONTINUE
  579.  
  580.  
  581. C  ****  INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  582. C  ****  DANS ITOPO .
  583. C
  584.       SEGINI,IITOP
  585.       IITOP(1)=1
  586.       DO 318 I=1,NNOE
  587.       IITOP(I+1)=IMIN(I)* 2  + IITOP(I)
  588.   318 CONTINUE
  589.       DO  I=1,NNOE
  590.       IMIN(I)=0
  591.       enddo
  592.       IENNO=IITOP(NNOE+1)
  593.       SEGINI,ITOPO
  594.       DO 321 IRI=1,NNVA
  595.       MELEME=IRIGEL(1,IRI)
  596.       SEGACT,MELEME
  597.       N1=NUM(/1)
  598.       N2=NUM(/2)
  599.       DO  I=1,N2
  600.       DO  J=1,N1
  601.       K=NUM(J,I)
  602.       M=INUINV(K)
  603.       IMIN(M)=IMIN(M)+1
  604.       IUY= 2* ( IMIN(M)-1 )  + IITOP(M)
  605.       ITOPO(IUY)=I
  606.       ITOPO(IUY+1)=IRI
  607.       enddo
  608.       enddo
  609.       SEGDES,MELEME
  610.   321 CONTINUE
  611. C
  612. C ***  NUMEROTATION DES INCONNUES DE INCPO
  613. C
  614.       NA=0
  615.  
  616.        DO 337 I=1,NNOE
  617.         nad=na
  618.         diamax=0.d0
  619.         DO 335 K=1,MAXINC
  620.         IF(INCPO(K,I).EQ.0) GO TO 335
  621.         IF (INCPO(K,I).LT.MAXPOD) THEN
  622.           NA=NA+1
  623.           INCPO(K,I)=NA
  624.           itrv1(na-nad)=k
  625.           dtrv1(na-nad)= -diatmp(k,i)
  626.           diamax=max(diamax,abs(dtrv1(na-nad)))
  627.         ENDIF
  628.   335   CONTINUE
  629.       diaref = diamax * xszpre
  630. *  pour les multiplicateurs de lagrange?
  631.       do k=1,na-nad
  632.        if (abs(dtrv1(k)).lt.diaref) then
  633. **      write (6,*) ' terme diag petit ',dtrv1(k)
  634.         dtrv1(k)=dtrv1(k)+diamax
  635.        endif
  636.       enddo
  637. *  trier incpo suivant les val de diatmp
  638.       call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  639.       do k=1,na-nad
  640.        incpo(itrv1(k),i)=k+nad
  641.       enddo
  642.   337  CONTINUE
  643.       DO 339 I=1,NTTMAI(/1)
  644.         NAD=NA
  645.         diamax=0.d0
  646.         N1=NTTMAI(I)
  647.         DO 338 K=1,MAXINC
  648.         IF(INCPO(K,N1).EQ.0) GO TO 338
  649.         IF (INCPO(K,N1).EQ.MAXPOD) THEN
  650.           NA=NA+1
  651.           INCPO(K,N1)=NA
  652.           itrv1(na-nad)=k
  653.           dtrv1(na-nad)= -diatmp(k,n1)
  654.           diamax=max(diamax,abs(dtrv1(na-nad)))
  655.         ENDIF
  656.  338    CONTINUE
  657.       diaref = diamax * xszpre
  658. *  pour les multiplicateurs de lagrange?
  659.       do k=1,na-nad
  660.        if (abs(dtrv1(k)).lt.diaref) then
  661. **      write (6,*) ' terme diag petit ',dtrv1(na-nad)
  662.         dtrv1(k)=dtrv1(k)+diamax
  663.        endif
  664.       enddo
  665. *  trier incpo suivant les val de diatmp
  666.       call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  667.       do  k=1,na-nad
  668.        incpo(itrv1(k),n1)=k+nad
  669.       enddo 
  670.  339  CONTINUE
  671. C
  672. C  CREATION DU DESCRIPTEUR DE LA RIGIDITE EQUIVALENTE
  673. C
  674.       NLIGRD=NLIGRA
  675.       NLIGRP=NLIGRA
  676.       SEGINI,DES1
  677.       DO 341 IGLOB=1,NOMAI(/1)
  678.         IF(NOMAI(IGLOB).EQ.0) GOTO 341
  679.         ILOC=INUINV(IGLOB)
  680.         DO 342 I=1,INCPO(/1)
  681.            IF(INCPO(I,ILOC).GT.NBNNMA) THEN
  682.               ICOL=INCPO(I,ILOC)-NBNNMA
  683.               DES1.NOELEP(ICOL)=NOMAI(IGLOB)
  684.               DES1.NOELED(ICOL)=NOMAI(IGLOB)
  685.               DES1.LISINC(ICOL)=IMIK(I)
  686.               DES1.LISDUA(ICOL)=IDUA(I)
  687.             ENDIF
  688.  342    CONTINUE
  689.  341  CONTINUE
  690.       segsup diatmp,strv
  691.       SEGDES DES1
  692.  
  693.       SEGDES,MIDUA,MIMIK,MHARK
  694.  
  695.       SEGDES,MRIGID
  696.  
  697.       SEGDES,ITOPO
  698.       SEGDES,IITOP
  699.       SEGDES,INUINV
  700.       SEGDES,IPT1
  701.       SEGDES,MINCPO
  702.       SEGSUP,IMIN
  703.       SEGDES,INCTRR
  704.       INCTRY=INCTRR
  705.       SEGINI,MMATRI
  706.       NENS=0
  707.       IGEOMA=IPT1
  708.       IIDUA=MIDUA
  709.       IINCPO=MINCPO
  710.       IIMIK=MIMIK
  711.       IHARK=MHARK
  712.       INUINY=INUINV
  713.       ITOPOY=ITOPO
  714.       IITOPY=IITOP
  715.       MMATRX=MMATRI
  716.       SEGDES,MMATRI
  717.       SEGDES,ILOCAL
  718.       SEGDES,MELEME
  719.       SEGDES,DESCR
  720.       SEGDES,SNTT
  721.       SEGDES,SNTO
  722.       SEGDES NOMAI
  723.       SEGDES SNOMIN
  724.       RETURN
  725.       END
  726.  
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  
  734.  
  735.  
  736.  
  737.  
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  
  754.  
  755.  
  756.  
  757.  
  758.  
  759.  
  760.  
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  

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