Télécharger la plaquette Cast3M


fr en

Télécharger assem1.eso

Retour à la liste

Numérotation des lignes : 

assem1

  1. C ASSEM1    SOURCE    MB234859  26/09/01    21:15:05     12631          
  2.       SUBROUTINE ASSEM1(IPOIRI,INSYM,MMATRX,INUINY,
  3.      &                  ITOPOY,IPOY,IITOPY,INCTRY,
  4.      &                  ITOPOD,IPOD,IITOPD,INCTRD)
  5. C-----------------------------------------------------------------------
  6. c  Preparation de l'assemblage des matrices de rigidites elementaires
  7. c  Effectuer une renumerotation par la nested dissection ou reverse
  8. c  cuthill mckee (subroutine numopt)
  9. C
  10. C  Entrees :
  11. C  ---------
  12. C    IPOIRI : Pointeur sur la rigidite totale
  13. C    INSYM  : Entier valant 0 si matrices symetriques
  14. C                           1 si matrices non symetriques
  15. C
  16. C  Sorties :
  17. C  ---------
  18. C    MMATRX : Pointeur sur le segment MMATRI
  19. C    INUINY : Pointeur sur le segment INUINV
  20. C
  21. C    ITOPOY : Pointeur sur le segment ITOPO
  22. C    IPOY   : Pointeur sur le segment IPOS
  23. C    IITOPY : Pointeur sur le segment IITOP
  24. C    INCTRY : Pointeur sur le segment INCTRR
  25. C
  26. C  En cas de matrice non symetrique sont egalement renseignes
  27. C    ITOPOD : Pointeur sur le segment ITOPOB
  28. C    IPOD   : Pointeur sur le segment IPOSB
  29. C    IITOPD : Pointeur sur le segment IITOPB
  30. C    INCTRD : Pointeur sur le segment INCTRS
  31. C
  32. C  Remarques :
  33. C  1/ Les elements modifies dans le segment mmatri future matrice
  34. C     triangularisee sont :
  35. C       NENS   : Entier valant 0
  36. C       IGEOMA : Pointeur sur le segment IPT1
  37. C       IIDUA  : Pointeur sur le segment MIDUA
  38. C       IINCPO : Pointeur sur le segment MINCPO
  39. C       IIMIK  : Pointeur sur le segment MIMIK
  40. C       IHARK  : Pointeur sur le segment MHARK
  41. C     En cas de matrice non symetrique sont egalement renseignes
  42. C       IDUAPO : Pointeur sur le segment MIPO1
  43. C       IHARDU : Pointeur sur le segment MHAR1
  44. C  2/ Les segments autres que mmatri sont des objets de travail
  45. C     servant a l'assemblage et seront supprimes en fin d'assemblage
  46. C     ou de triangularisation.
  47. C-----------------------------------------------------------------------
  48.       IMPLICIT INTEGER(I-N)
  49.       IMPLICIT REAL*8 (A-H,O-Z)
  50. -INC PPARAM
  51. -INC CCOPTIO
  52. -INC CCHAMP
  53. -INC SMELEME
  54. -INC SMCOORD
  55. -INC CCREEL
  56.       SEGMENT,IMIN(NNOE)
  57.       SEGMENT,IMINB(NNOE)
  58.       SEGMENT ICPR(nbpts)
  59. -INC SMRIGID
  60. -INC SMMATRI
  61. C
  62.       SEGMENT,INUINV(NNGLOB)
  63.       SEGMENT,ITOPO(IENNO)
  64.       SEGMENT,ITOPOB(IENNO)
  65.       SEGMENT,IITOP(NNOE+1)
  66.       SEGMENT,IITOPB(NNOE+1)
  67.       SEGMENT,IMINI(INC)
  68.       SEGMENT,IPOS(NNOE1)
  69.       SEGMENT,IPOSB(NNOE1)
  70.       SEGMENT,INCTRR(NIRI)
  71.       SEGMENT,INCTRS(NIRI)
  72.       SEGMENT,INCTRA(NLIGRE)
  73.       SEGMENT DIATMP(maxt,NNOE)
  74.       SEGMENT STRV
  75.         INTEGER ITRV1(MAXT)
  76.         INTEGER ITRV2(MAXT)
  77.         REAL*8  DTRV1(MAXT)
  78.         REAL*8  DTRV2(MAXT)
  79.       ENDSEGMENT
  80.       segment mondu
  81.          character*(lochpo) mondua(nnn)
  82.          integer ipris(nnn),inosel(nnn)
  83.       endsegment
  84. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  85. C  ****  CES TABLEAUX SERVENT AU REPERAGE DE LA MATRICE POUR L'ASSEMBLAG
  86. C  ****  IL SERONT TOUS SUPPRIMES EN FIN D'ASSEMBLAGE.
  87. C
  88. C  ****   MAXINC= MAXIMUM DE COMPOSANTES CONCERNANT UN NOEUD
  89. C
  90. C  ****   IITOP(K)=I LE 1ER ELEMENT TOUCHANT LE NOEUD K SE TROUVE EN
  91. C                    IEME POSITION DANS ITOPO
  92. C  ****   ITOPO(I)=L: LE 1ER ELEMENT TOUCHANT LE K EME NOEUD DE LA
  93. C         ITOPO(I+1)=M  MATRICE EST LE LIEME  DE L'OBJET GEOMETRIE
  94. C                       DEFINI PAR LE POINTEUR M
  95. C  ****   IPOS(I)=J   : LA 1 ERE INCONNUE DU NOEUD I EST EN J+1 EME
  96. C                       POSITION
  97. C  ****  IMINI(I)=J     LA PLUS PETITE INCONNUE QUI EST RELIEE A LA IEME
  98. C                       EST L'INCONNUE J.
  99. C  ****  INUINV(I)=J    J EST LE NOUVEAU NUMERO DU NOEUD I
  100. C
  101. C  ****  INCTRR(NIRI) - NIRI=NRIGEL du IPOIRI (objet MRIGID passé en argument)
  102. C                       pointeurs sur INCTRA
  103. C
  104. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  105.       CHARACTER*4 CNOHA,lisi
  106.       integer*4   noha
  107.       equivalence (cnoha,noha)
  108.       DATA CNOHA/'NOHA'/
  109.       DATA IPOIN/1/
  110.       LOGICAL bNONSYM
  111. C
  112.       bNONSYM=(INSYM.EQ.1)
  113. C
  114.       NNGLOB=nbpts
  115.       MRIGID=IPOIRI
  116. C
  117. C     Quelquefois, les points de IRIGEL(1,I) ne sont pas
  118. C     tous references par le segment DESCR (cas des QUAFs notamment).
  119. C     Dans ce cas, on fait une reduction du MELEME et on le stocke dans
  120. C     IRIGEL(2,I)
  121. C
  122.       CALL RDSCRM(MRIGID)
  123.       IF (IERR.NE.0) RETURN
  124. C
  125.       SEGACT,MRIGID
  126.       NNVA=IRIGEL(/2)
  127. C
  128.       DO IR=1,NNVA
  129.         MELEME=IRIGEL(1,IR)
  130.         DESCR =IRIGEL(3,IR)
  131.         SEGACT,MELEME,DESCR
  132.       ENDDO
  133. C
  134.       NIRI=NNVA
  135.       SEGINI,INCTRR
  136.       IF (bNONSYM) SEGINI,INCTRS
  137.  
  138.       IF (NNVA.EQ.0) GOTO 801
  139.       MELEME=IRIGEL(1,1)
  140. C ... ITYPEL = 27 correspond aux éléments 'ATTA' ...
  141.       IF (ITYPEL.NE.27) GOTO 801
  142. C
  143. C  **** ASSEMBLAGE DANS LE CAS DE L'ANALYSE MODALE. ON COMPTE LES POINTS
  144. C  **** DANS ICPR
  145. C
  146.       SEGINI INUINV,ICPR
  147.       IKI=0
  148.       DO 700 I=1,NNVA
  149.         MELEME=IRIGEL(1,I)
  150.         NBNN=NUM(/1)
  151.         NBELEM=NUM(/2)
  152.         DO I1=1,NBELEM
  153.           DO 701 I2=1,NBNN
  154.             IP1=NUM(I2,I1)
  155.             IF(ICPR(IP1).NE.0) GOTO 701
  156.             IKI=IKI+1
  157.             ICPR(IP1)=IKI
  158.  701      CONTINUE
  159.         ENDDO
  160.  700  CONTINUE
  161. C
  162. C  **** FABRICATION DU TABLEAU INUINV
  163. C
  164.       NNOE=IKI
  165.       NBETA=0
  166.       DO 710 I=1,NNVA
  167.         MELEME=IRIGEL(1,I)
  168.         NBNN=NUM(/1)
  169.         NBELEM=NUM(/2)
  170.         DO I1=1,NBELEM
  171.           DO 711 I2=1,NBNN
  172.             IP1=NUM(I2,I1)
  173.             IF(ICPR(IP1).EQ.0) GOTO 711
  174.             NBETA=NBETA+1
  175.             IKI=NNOE-NBETA+1
  176.             INUINV(IP1)=IKI
  177.             ICPR(IP1)=0
  178.  711      CONTINUE
  179.         ENDDO
  180.  710  CONTINUE
  181.       SEGSUP,ICPR
  182.       ICDOUR=NNOE
  183.       GOTO 800
  184. C
  185. C  ****  ON FABRIQUE UN NOUVEL OBJET GEOMETRIE CONTENANT TOUTES LES
  186. C  ****  GEOMETRIES ELEMENTAIRES. CET OBJET CONTIENT NNVA OBJETS
  187. C  ****  GEOMETRIQUES ELEMENTAIRES. PUIS ON ENVOIE DANS NUMOPT QUI
  188. C  ****  FOURNIT EN RETOUR INUINV(NUM(I,J))=K DONNE LE NOUVEAU
  189. C  ****  NUMERO LOCAL DU POINT NUM(I,J).K VARIE DE 1 A ICDOUR.
  190. C  ****  LE PREMIER NOEUD DE L'OBJET GEOMETRIQUE EST LE PREMIER NOEUD
  191. C  ****  DE LA MATRICE, ETC...
  192. C
  193.  801  CONTINUE
  194.       IKK=1
  195. C
  196.  722  CONTINUE
  197.       IF(IKK.GT.NNVA) GOTO 723
  198.       MELEME=IRIGEL(1,IKK)
  199.       DESCR =IRIGEL(3,IKK)
  200.       NLIGRE=LISINC(/2)
  201.       DO 720 K=1,NLIGRE
  202.         IF(LISINC(K).NE.'LX  ') GOTO 721
  203.   720 CONTINUE
  204.       IKK=IKK+1
  205.       IF(IKK.LE.NNVA) GOTO 722
  206. C
  207.  723  CONTINUE
  208.       DO 4862 I=1,NNVA
  209.         MELEME= IRIGEL(1,I)
  210.         if (num(/2).eq.0) goto 4862
  211.         IF (ITYPEL.EQ.49) THEN
  212.           K=3
  213.           if (num(/2).le.2) k=num(/2)
  214.           GOTO 721
  215.         ENDIF
  216.  4862 CONTINUE
  217.       K=1
  218.       do ir=1,nnva
  219.         MELEME= IRIGEL(1,ir)
  220.         if (num(/2).ne.0.and.itypel.ne.49) goto 4864
  221.       enddo
  222.       call erreur(5)
  223. 4864  CONTINUE
  224.       DESCR= IRIGEL(3,ir)
  225. C ... I1 = numéro (absolu) du noeud concerné par le DDL No K,
  226. C     Ce noeud sera mis dans un MELEME dont le pointeur est stocké dans IMELP ...
  227.   721 CONTINUE
  228.       I1=NUM(NOELEP(K),1)
  229.       NBSOUS=0
  230.       NBNN=1
  231.       NBREF=0
  232.       NBELEM=1
  233.       SEGINI,MELEME
  234.       ITYPEL=1
  235.       NUM(1,1)=I1
  236.       IMELP=MELEME
  237. C
  238. C ... Le MELEME créé ici est un MELEME composé qui contiendra le MELEME
  239. C     pointé par IMELP et tous les MELEME pointés par IRIGEL(1,*) ...
  240.       NBSOUS=NNVA+1
  241.       NBREF=0
  242.       NBNN=0
  243.       NBELEM=0
  244.       SEGINI,MELEME
  245.       LISOUS(1)=IMELP
  246.       INCMOY = 0
  247.       NOEMOY = 0
  248.       DO 12 I=1,NNVA
  249.         IPT1 =IRIGEL(1,I)
  250.         DESCR=IRIGEL(3,I)
  251. C
  252.         NLIGRE=LISINC(/2)
  253.         INCMOY = INCMOY + NLIGRE*ipt1.num(/2)
  254.         NOEMOY = NOEMOY + ipt1.num(/1)*ipt1.num(/2)
  255. *  cas du frottement, on met -49 dans itypel pour le savoir dans numopt
  256.         IF (IRIGEL(6,i).eq.2) then
  257.           IPT8=ipt1
  258.           if (ipt8.itypel.eq.49) then
  259.             segact IPT8*mod
  260.             ipt8.itypel=-49
  261.           endif
  262.           ipt2=ipt8
  263.         else
  264.           ipt2=irigel(2,i)
  265.           if (ipt2.eq.0) ipt2=ipt1
  266.         ENDIF
  267.         LISOUS(I+1)=ipt2
  268.    12 CONTINUE
  269.       INCMOY = INCMOY/NOEMOY
  270. **    write(6,*) 'ASSEM1 incmoy noemoy ',incmoy,noemoy
  271.       ICDOUR=0
  272.       SEGINI,INUINV
  273.       SEGDES,INUINV
  274.       CALL NUMOPT(MELEME,INUINV,ICDOUR)
  275. C
  276.       segact meleme
  277.       do i=1,lisous(/1)
  278.         ipt8=lisous(i)
  279.         segact ipt8
  280.         if (ipt8.itypel.eq.-49) then
  281.           segact ipt8*mod
  282.           ipt8.itypel=49
  283.         endif
  284.       enddo
  285.       SEGACT INUINV
  286.       SEGSUP,MELEME
  287. *     MELEME=IMELP
  288. *     SEGSUP,MELEME
  289. C
  290. C  ****  CREATION D'UN OBJET GEOMETRIE QU'IL FAUDRA CHANGER EN CAS DE
  291. C  ****  RENUMEROTATION GENERALE.ON PROFITE DE LA BOUCLE POUR CREE LE
  292. C  ****  TABLEAU IMIN(I)=J QUI DIT QUE J ELEMENTS TOUCHE LE NOEUD I(NU-
  293. C  ****  MEROTATION LOCALE).
  294. C
  295.  800  CONTINUE
  296.       NNOE=ICDOUR
  297.       SEGINI,IMIN
  298.       NNOE1=NNOE+1
  299.       SEGINI,IPOS
  300.       IF (bNONSYM) SEGINI,IMINB,IPOSB
  301.       NBSOUS=0
  302.       NBREF=0
  303.       NBNN=1
  304.       NBELEM=ICDOUR
  305.       SEGINI,IPT1
  306.       IPT1.ITYPEL=IPOIN
  307.       DO 16 IRI=1,NNVA
  308.         MELEME=IRIGEL(1,IRI)
  309.         DESCR =IRIGEL(3,IRI)
  310.         N2=NUM(/2)
  311.         DO 17 I=1,N2
  312.           DO 171 J=1,NOELEP(/1)
  313.             K=NUM(NOELEP(J),I)
  314.             M=INUINV(K)
  315.             IF (IPOS(M).NE.I) THEN
  316.               IMIN(M)=IMIN(M)+1
  317.               IPT1.NUM(1,M)=K
  318.               IPOS(M)=I
  319.             ENDIF
  320.  171      CONTINUE
  321.           IF (.NOT.bNONSYM) GOTO 17
  322.           DO 172 J=1,NOELED(/1)
  323.             K=NUM(NOELED(J),I)
  324.             M=INUINV(K)
  325.             IF (IPOSB(M).NE.I) THEN
  326.               IMINB(M)=IMINB(M)+1
  327.               IPOSB(M)=I
  328.             ENDIF
  329.  172      CONTINUE
  330.  17     CONTINUE
  331.         DO 15 I=1,N2
  332.           DO J=1,NOELEP(/1)
  333.             K=NUM(NOELEP(J),I)
  334.             M=INUINV(K)
  335.             ipos(m)=0
  336.           ENDDO
  337.           IF (.NOT.bNONSYM) GOTO 15
  338.           DO J=1,NOELED(/1)
  339.             K=NUM(NOELED(J),I)
  340.             M=INUINV(K)
  341.             IPOSB(m)=0
  342.           ENDDO
  343.    15   CONTINUE
  344.    16 CONTINUE
  345. C
  346. C  ****  INITIALISATION DE ITOPO. ON UTILISE IMIN POUR SE POSITIONNER
  347. C  ****  DANS ITOPO .
  348. C  ... ITOPO contiendra pour chaque noeud et chaque élément contenant
  349. C      ce noeud 2 nombres :
  350. C            1. numéro de l'élément dans son maillage
  351. C            2. numéro du maillage (dans IRIGEL) de cet élément
  352. C
  353.       SEGINI,IITOP
  354.       IITOP(1)=1
  355.       IF (bNONSYM) THEN
  356.         SEGINI,IITOPB
  357.         IITOPB(1)=1
  358.       ENDIF
  359.       DO 18 I=1,NNOE
  360.         IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  361.         IF (bNONSYM) IITOPB(I+1)=IMINB(I)* 2 + IITOPB(I)
  362.    18 CONTINUE
  363.       DO I=1,NNOE
  364.         IMIN(I)=0
  365.         IF (bNONSYM) IMINB(I)=0
  366.       enddo
  367.       IENNO=IITOP(NNOE+1)
  368.       SEGINI,ITOPO
  369.       IF (bNONSYM) THEN
  370.         IENNO=IITOPB(NNOE+1)
  371.         SEGINI ITOPOB
  372.       ENDIF
  373.       DO 21 IRI=1,NNVA
  374.         MELEME=IRIGEL(1,IRI)
  375.         DESCR =IRIGEL(3,IRI)
  376.         N2=NUM(/2)
  377.         DO 22 I=1,N2
  378.           DO 221 J=1,NOELEP(/1)
  379.             M=INUINV(NUM(NOELEP(J),I))
  380.             IF (IPOS(M).NE.I) THEN
  381.               IMIN(M)=IMIN(M)+1
  382.               IUY= 2* ( IMIN(M)-1 )  + IITOP(M)
  383.               ITOPO(IUY)=I
  384.               ITOPO(IUY+1)=IRI
  385.               IPOS(M)=I
  386.             ENDIF
  387.  221      CONTINUE
  388.           IF (.NOT.bNONSYM) GOTO 22
  389.           DO 222 J=1,NOELED(/1)
  390.             M=INUINV(NUM(NOELED(J),I))
  391.             IF (IPOSB(M).NE.I) THEN
  392.               IMINB(M)=IMINB(M)+1
  393.               IUY= 2* ( IMINB(M)-1 )  + IITOPB(M)
  394.               ITOPOB(IUY)=I
  395.               ITOPOB(IUY+1)=IRI
  396.               IPOSB(M)=I
  397.             ENDIF
  398.  222      CONTINUE
  399.  22     CONTINUE
  400.         DO 210 I=1,N2
  401.           DO J=1,NOELEP(/1)
  402.             M=INUINV(NUM(NOELEP(J),I))
  403.             IPOS(M)=0
  404.           ENDDO
  405.           IF (.NOT.bNONSYM) GOTO 210
  406.           DO J=1,NOELED(/1)
  407.             M=INUINV(NUM(NOELED(J),I))
  408.             IPOSB(M)=0
  409.           ENDDO
  410.   210   CONTINUE
  411.    21 CONTINUE
  412. C
  413. C  RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  414. C  DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  415. C
  416.       DO 230 IRI=1,NNVA
  417.         IHARIR=IRIGEL(5,IRI)
  418.         IF (IHARIR . NE. NOHA) THEN
  419.           IARDEF = IHARIR
  420.           GOTO 231
  421.         ENDIF
  422.   230 CONTINUE
  423. c     CALL ERREUR (21)
  424. c     RETURN
  425. cbp: si toutes ont pour valeur NOHA, ce n'est a priori pas une erreur...
  426.   231 CONTINUE
  427.       DO 232 IRI=1,NNVA
  428.         IF (IRIGEL(5,IRI).EQ.NOHA  ) GOTO 232
  429.         IF (IRIGEL(5,IRI).EQ.IARDEF) GOTO 232
  430.         if (iimpi.ne.0) then
  431.             write(ioimp,*) 'IRIGEL(5,:)=',(IRIGEL(5,iou),iou=1,NNVA)
  432.          endif
  433.          CALL ERREUR (435)
  434.          RETURN
  435.  232  CONTINUE
  436. C
  437. C  ****  RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  438. C
  439.       SEGINI,MIDUA
  440.       SEGINI,MIMIK
  441.       SEGINI,MHARK
  442.       IF (bNONSYM) SEGINI,MHAR1
  443.  
  444.       DESCR=IRIGEL(3,1)
  445.       IAAR =IRIGEL(5,1)
  446.       IF(IAAR.EQ.NOHA) IAAR = IARDEF
  447.       IMIK(**)=LISINC(1)
  448.       IHAR(**)= IAAR
  449.       IDUA(**)=LISDUA(1)
  450.       IF (bNONSYM) MHAR1.IHAR(**)= IAAR
  451.  
  452.       MAXINC=1
  453.       DO 23 IRI=1,NNVA
  454.         DESCR=IRIGEL(3,IRI)
  455.         IHARIR=IRIGEL(5,IRI)
  456.         IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  457.         NLIGRE=LISINC(/2)
  458.         DO 26 I=1,NLIGRE
  459.           DO 24 J=1,MAXINC
  460.             IF (IMIK(J).NE.LISINC(I)) GOTO 24
  461.             IF (.NOT.bNONSYM) THEN
  462.               IF (IDUA(J).NE.LISDUA(I)) THEN
  463.                 MOTERR(1:4)=IMIK(J)
  464.                 MOTERR(5:8)=IDUA(J)
  465.                 MOTERR(9:12)=LISDUA(I)
  466.                 CALL ERREUR(1026)
  467.                 RETURN
  468.               ENDIF
  469.             ENDIF
  470.             IF (IHAR(J).EQ.IHARIR)    GOTO 26
  471. C
  472.    24     CONTINUE
  473.           MAXINC=MAXINC+1
  474.           IHAR(**)=IHARIR
  475.           IMIK(**)=LISINC(I)
  476.           IF (.NOT.bNONSYM) IDUA(**)=LISDUA(I)
  477.    26   CONTINUE
  478.    23 CONTINUE
  479. C
  480.       MAXI=MAXINC
  481.       SEGINI,MINCPO
  482.       MAXT=MAXINC
  483.       IF (.NOT.bNONSYM) GOTO 555
  484. C
  485.       MAXDUA=1
  486.       DO 2322 IRI=1,NNVA
  487.         DESCR=IRIGEL(3,IRI)
  488.         IHARIR=IRIGEL(5,IRI)
  489.         IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  490.         NLIGRE=LISDUA(/2)
  491.         DO 262 I=1,NLIGRE
  492.           DO 242 J=1,MAXDUA
  493.             IF (IDUA(J).NE.LISDUA(I))    GOTO 242
  494.             IF (MHAR1.IHAR(J).EQ.IHARIR) GOTO 262
  495. C
  496.   242     CONTINUE
  497.           MAXDUA=MAXDUA+1
  498.           MHAR1.IHAR(**)=IHARIR
  499.           IDUA(**)=LISDUA(I)
  500.   262   CONTINUE
  501.  2322 CONTINUE
  502. *     write(6,*) ' imik'
  503. *     write(6,*) ( imik(iu),iu=1,imik(/2))
  504. *     write(6,*) ' idua avant'
  505. *     write(6,*) ( idua(iu),iu=1,idua(/2))
  506.       nnn = idua(/2)
  507.       nqq = imik(/2)
  508.       if (nnn.ne.nqq) then
  509. *  on verra plus tard
  510.         call erreur(756)
  511.         return
  512.       endif
  513. * petit travail pour mettre dans le meme ordre les inconnues
  514.       segini mondu
  515.       do 476 iu=1,imik(/2)
  516.         lisi=imik(iu)
  517.         CALL PLACE(NOMDD,LNOMDD,idx,lisi)
  518.         IF (idx.NE.0) THEN
  519.           lisi=NOMDU(idx)
  520.         ENDIF
  521.         do 477 io=1,idua(/2)
  522.           if(idua(io).eq.lisi) go to 478
  523.  477    continue
  524.         inosel(iu)=1
  525.         go to 476
  526.  478    continue
  527.         mondua(iu)= idua(io)
  528.         ipris(io)=1
  529.  476  continue
  530.       do 472 iu=1,inosel(/1)
  531.         if (inosel(iu).eq.0) go to 472
  532.         do 473 io=1,ipris(/1)
  533.           if (ipris(io).eq.1) go to 473
  534.           ipris(io)=1
  535.           mondua(iu)=idua(io)
  536.           go to 472
  537.  473    continue
  538.  472  continue
  539.       do 479 iu=1,idua(/2)
  540.         idua(iu)=mondua(iu)
  541.  479  continue
  542.       segsup mondu
  543. *     write(6,*) ' idua apres'
  544. *     write(6,*) ( idua(iu),iu=1,idua(/2))
  545. C
  546.       MAXI=MAXDUA
  547.       SEGINI,MIPO1
  548.       maxt=max(maxinc,maxdua)
  549. C
  550. C  **** INITIALISATION DE INCPOS ET DE INCTRA.
  551. C
  552.  555  CONTINUE
  553.       SEGINI DIATMP,strv
  554.  
  555.       DO 29 IRI=1,NNVA
  556.         IHARIR=IRIGEL(5,IRI)
  557.         IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  558.  
  559.         DESCR=IRIGEL(3,IRI)
  560.         NLIGRE=LISINC(/2)
  561.         NLIGRF=LISDUA(/2)
  562.         SEGINI,INCTRA
  563.         INCTRR(IRI)=INCTRA
  564.  
  565.         MELEME=IRIGEL(1,IRI)
  566.         N2=NUM(/2)
  567.  
  568.         XMATRI=IRIGEL(4,IRI)
  569.         SEGACT XMATRI
  570.  
  571.         DO 34 J=1,NLIGRE
  572.           DO 33 K=1,MAXINC
  573.             IF (IMIK(K).NE.LISINC(J)) GOTO 33
  574.             IF (IHAR(K).EQ.IHARIR)    GOTO 32
  575.  33       CONTINUE
  576.           CALL ERREUR(5)
  577. C
  578.  32       CONTINUE
  579.           INCTRA(J)=K
  580.           DO 31 I=1,N2
  581.             IJ=INUINV(NUM(NOELEP(J),I))
  582.             INCPO(K,IJ)=1
  583. *  terme diagonal
  584.             if ((bNONSYM.AND.(j.le.nligrf)).OR.(.NOT.bNONSYM))
  585.      &        diatmp(K,IJ)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
  586.  31       continue
  587.  34     CONTINUE
  588.         SEGDES,INCTRA
  589.         IF (.NOT.bNONSYM) GOTO 30
  590. C
  591.         NLIGRF=LISINC(/2)
  592.         NLIGRE=LISDUA(/2)
  593.         SEGINI,INCTRA
  594.         INCTRS(IRI)=INCTRA
  595.  
  596.         DO 342 J=1,NLIGRE
  597.           DO 332 K=1,MAXDUA
  598.             IF (IDUA(K).NE.LISDUA(J))    GOTO 332
  599.             IF (MHAR1.IHAR(K).EQ.IHARIR) GOTO 322
  600.   332     CONTINUE
  601.           CALL ERREUR(5)
  602. C
  603.   322     CONTINUE
  604.           INCTRA(J)=K
  605.           DO  I=1,N2
  606.             IJ=INUINV(NUM(NOELED(J),I))
  607.             MIPO1.INCPO(K,IJ)=1
  608. *  terme diagonal
  609.             if (j.le.nligrf) diatmp(K,IJ)=diatmp(k,ij)+
  610.      >        re(j,j,i)*coerig(iri)
  611.           enddo
  612.   342   CONTINUE
  613.         SEGDES,INCTRA
  614. C
  615.  30     CONTINUE
  616.         SEGDES XMATRI
  617.  29   CONTINUE
  618. C
  619. C  ****  INITIALISATION DE IPOS
  620. C
  621.       IPOS(1)=0
  622.       NA=0
  623.       IF (bNONSYM) THEN
  624.         IPOSB(1)=0
  625.         ND=0
  626.       ENDIF
  627.       DO 37 I=1,NNOE
  628.         nad=na
  629.         diamax=0.d0
  630.         DO 35 K=1,MAXINC
  631.           IF(INCPO(K,I).EQ.0) GOTO 35
  632.           NA=NA+1
  633.           INCPO(K,I)=NA
  634.           itrv1(na-nad)=k
  635.           dtrv1(na-nad)= -diatmp(k,i)
  636.           diamax=max(diamax,abs(dtrv1(na-nad)))
  637.  35     CONTINUE
  638.         diaref = diamax * xszpre
  639.         do k=1,na-nad
  640.           if (abs(dtrv1(k)).lt.diaref) then
  641. **      write (6,*) ' terme diag petit ',dtrv1(k)
  642.             dtrv1(k)=dtrv1(k)+diamax
  643.           endif
  644.         enddo
  645. *  trier incpo suivant les val de diatmp
  646.         call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  647.         do 351 k=1,na-nad
  648.           incpo(itrv1(k),i)=k+nad
  649.  351    continue
  650.         IPOS(I+1)=NA
  651. C
  652.         IF (.NOT.bNONSYM) GOTO 37
  653. C
  654.         ndd=nd
  655.         diamax=0.d0
  656.         DO 352 K=1,MAXDUA
  657.           IF(MIPO1.INCPO(K,I).NE.0) THEN
  658.             ND=ND+1
  659. C          ... MIPO1.INCPO(K,I) = numéro de l'équation ...
  660.             MIPO1.INCPO(K,I)=ND
  661.             itrv1(nd-ndd)=k
  662.             dtrv1(nd-ndd)= -diatmp(k,i)
  663.             diamax=max(diamax,abs(dtrv1(nd-ndd)))
  664.           ENDIF
  665.  352    CONTINUE
  666.         diaref = diamax * xszpre
  667.         do k=1,nd-ndd
  668.           if (abs(dtrv1(k)).lt.diaref) then
  669. **      write (6,*) ' terme diag petit ',dtrv1(k)
  670.             dtrv1(k)=dtrv1(k)+diamax
  671.           endif
  672.         enddo
  673.         call triflo(dtrv1,dtrv2,itrv1,itrv2,nd-ndd)
  674.         do k=1,nd-ndd
  675.           mipo1.incpo(itrv1(k),i)=k+ndd
  676.         enddo
  677.         IPOSB(I+1)=ND
  678.  37   CONTINUE
  679. C
  680.       DO IR=1,NNVA
  681.         MELEME=IRIGEL(1,IR)
  682.         DESCR =IRIGEL(3,IR)
  683.         SEGDES,MELEME,DESCR
  684.       ENDDO
  685. C
  686.       SEGDES,MIDUA,MIMIK,MHARK
  687. C
  688.       IF (bNONSYM) THEN
  689.         IF(NA.NE.ND) THEN
  690.           CALL ERREUR(756)
  691.           RETURN
  692.         ENDIF
  693. C
  694.         DO 567 IINO=1,NNOE1
  695.           IF (IPOS(IINO).NE.IPOSB(IINO)) THEN
  696.             WRITE(*,*) 'ERREUR dans ASNS1 !!! IPOS != IPOSB !!!'
  697.             RETURN
  698.           ENDIF
  699.  567    CONTINUE
  700.       ENDIF
  701. C
  702.       SEGINI,MMATRI
  703.       MMATRX=MMATRI
  704.       NENS=0
  705.       IGEOMA=IPT1
  706.       IIDUA=MIDUA
  707.       IINCPO=MINCPO
  708.       IIMIK=MIMIK
  709.       IHARK=MHARK
  710. C
  711.       INUINY=INUINV
  712.       ITOPOY=ITOPO
  713.       IPOY=IPOS
  714.       INCTRY=INCTRR
  715.       IITOPY=IITOP
  716.       SEGDES,ITOPO,IPOS,INCTRR,IITOP
  717.       SEGDES,MINCPO,MHARK
  718.       SEGSUP,IMIN
  719. C
  720.       IF (bNONSYM) THEN
  721.         IDUAPO=MIPO1
  722.         IHARDU=MHAR1
  723.         ITOPOD=ITOPOB
  724.         IPOD=IPOSB
  725.         INCTRD=INCTRS
  726.         IITOPD=IITOPB
  727.         SEGDES,ITOPOB,IPOSB,INCTRS,IITOPB
  728.         SEGDES,MIPO1,MHAR1
  729.         SEGSUP,IMINB
  730.       ELSE
  731.         ITOPOD=0
  732.         IPOD  =0
  733.         INCTRD=0
  734.         IITOPD=0
  735.       ENDIF
  736. C
  737.       SEGSUP,DIATMP,STRV
  738.       SEGDES,INUINV
  739.       SEGDES,MMATRI
  740.       SEGDES,MRIGID
  741.       END
  742.  
  743.  
  744.  

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