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/07/31    21:15:01     12613          
  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.       IF (bNONSYM) SEGINI,IITOPB
  355.       IITOP(1)=1
  356.       DO 18 I=1,NNOE
  357.         IITOP(I+1)=IMIN(I)* 2 + IITOP(I)
  358.         IF (bNONSYM) IITOPB(I+1)=IMINB(I)* 2 + IITOPB(I)
  359.    18 CONTINUE
  360.       DO I=1,NNOE
  361.         IMIN(I)=0
  362.         IF (bNONSYM) IMINB(I)=0
  363.       enddo
  364.       IENNO=IITOP(NNOE+1)
  365.       SEGINI,ITOPO
  366.       IF (bNONSYM) THEN
  367.         IENNO=IITOPB(NNOE+1)
  368.         SEGINI ITOPOB
  369.       ENDIF
  370.       DO 21 IRI=1,NNVA
  371.         MELEME=IRIGEL(1,IRI)
  372.         DESCR =IRIGEL(3,IRI)
  373.         N2=NUM(/2)
  374.         DO 22 I=1,N2
  375.           DO 221 J=1,NOELEP(/1)
  376.             M=INUINV(NUM(NOELEP(J),I))
  377.             IF (IPOS(M).NE.I) THEN
  378.               IMIN(M)=IMIN(M)+1
  379.               IUY= 2* ( IMIN(M)-1 )  + IITOP(M)
  380.               ITOPO(IUY)=I
  381.               ITOPO(IUY+1)=IRI
  382.               IPOS(M)=I
  383.             ENDIF
  384.  221      CONTINUE
  385.           IF (.NOT.bNONSYM) GOTO 22
  386.           DO 222 J=1,NOELED(/1)
  387.             M=INUINV(NUM(NOELED(J),I))
  388.             IF (IPOSB(M).NE.I) THEN
  389.               IMINB(M)=IMINB(M)+1
  390.               IUY= 2* ( IMINB(M)-1 )  + IITOPB(M)
  391.               ITOPOB(IUY)=I
  392.               ITOPOB(IUY+1)=IRI
  393.               IPOSB(M)=I
  394.             ENDIF
  395.  222      CONTINUE
  396.  22     CONTINUE
  397.         DO 210 I=1,N2
  398.           DO J=1,NOELEP(/1)
  399.             M=INUINV(NUM(NOELEP(J),I))
  400.             IPOS(M)=0
  401.           ENDDO
  402.           IF (.NOT.bNONSYM) GOTO 210
  403.           DO J=1,NOELED(/1)
  404.             M=INUINV(NUM(NOELED(J),I))
  405.             IPOSB(M)=0
  406.           ENDDO
  407.   210   CONTINUE
  408.    21 CONTINUE
  409. C
  410. C  RECHERCHE DE LA VALEUR PAR DEFAUT DE L'HARMONIQUE DANS LE CAS
  411. C  DE L'UTILISATION DE " OPTION MODE FOUR NOHAR "
  412. C
  413.       DO 230 IRI=1,NNVA
  414.         IHARIR=IRIGEL(5,IRI)
  415.         IF (IHARIR . NE. NOHA) THEN
  416.           IARDEF = IHARIR
  417.           GOTO 231
  418.         ENDIF
  419.   230 CONTINUE
  420. c     CALL ERREUR (21)
  421. c     RETURN
  422. cbp: si toutes ont pour valeur NOHA, ce n'est a priori pas une erreur...
  423.   231 CONTINUE
  424.       DO 232 IRI=1,NNVA
  425.         IF (IRIGEL(5,IRI).EQ.NOHA  ) GOTO 232
  426.         IF (IRIGEL(5,IRI).EQ.IARDEF) GOTO 232
  427.         if (iimpi.ne.0) then
  428.             write(ioimp,*) 'IRIGEL(5,:)=',(IRIGEL(5,iou),iou=1,NNVA)
  429.          endif
  430.          CALL ERREUR (435)
  431.          RETURN
  432.  232  CONTINUE
  433. C
  434. C  ****  RECHERCHE DE LA VALEUR MAXINC QUI PERMET DE DIMENSIONNER INCPOS
  435. C
  436.       SEGINI,MIDUA
  437.       SEGINI,MIMIK
  438.       SEGINI,MHARK
  439.       IF (bNONSYM) SEGINI,MHAR1
  440.  
  441.       DESCR=IRIGEL(3,1)
  442.       IAAR =IRIGEL(5,1)
  443.       IF(IAAR.EQ.NOHA) IAAR = IARDEF
  444.       IMIK(**)=LISINC(1)
  445.       IHAR(**)= IAAR
  446.       IDUA(**)=LISDUA(1)
  447.       IF (bNONSYM) MHAR1.IHAR(**)= IAAR
  448.  
  449.       MAXINC=1
  450.       DO 23 IRI=1,NNVA
  451.         DESCR=IRIGEL(3,IRI)
  452.         IHARIR=IRIGEL(5,IRI)
  453.         IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  454.         NLIGRE=LISINC(/2)
  455.         DO 26 I=1,NLIGRE
  456.           DO 24 J=1,MAXINC
  457.             IF (IMIK(J).NE.LISINC(I)) GOTO 24
  458.             IF (.NOT.bNONSYM) THEN
  459.               IF (IDUA(J).NE.LISDUA(I)) THEN
  460.                 MOTERR(1:4)=IMIK(J)
  461.                 MOTERR(5:8)=IDUA(J)
  462.                 MOTERR(9:12)=LISDUA(I)
  463.                 CALL ERREUR(1026)
  464.                 RETURN
  465.               ENDIF
  466.             ENDIF
  467.             IF (IHAR(J).EQ.IHARIR)    GOTO 26
  468. C
  469.    24     CONTINUE
  470.           MAXINC=MAXINC+1
  471.           IHAR(**)=IHARIR
  472.           IMIK(**)=LISINC(I)
  473.           IF (.NOT.bNONSYM) IDUA(**)=LISDUA(I)
  474.    26   CONTINUE
  475.    23 CONTINUE
  476. C
  477.       MAXI=MAXINC
  478.       SEGINI,MINCPO
  479.       MAXT=MAXINC
  480.       IF (.NOT.bNONSYM) GOTO 555
  481. C
  482.       MAXDUA=1
  483.       DO 2322 IRI=1,NNVA
  484.         DESCR=IRIGEL(3,IRI)
  485.         IHARIR=IRIGEL(5,IRI)
  486.         IF(IHARIR. EQ.NOHA ) IHARIR = IARDEF
  487.         NLIGRE=LISDUA(/2)
  488.         DO 262 I=1,NLIGRE
  489.           DO 242 J=1,MAXDUA
  490.             IF (IDUA(J).NE.LISDUA(I))    GOTO 242
  491.             IF (MHAR1.IHAR(J).EQ.IHARIR) GOTO 262
  492. C
  493.   242     CONTINUE
  494.           MAXDUA=MAXDUA+1
  495.           MHAR1.IHAR(**)=IHARIR
  496.           IDUA(**)=LISDUA(I)
  497.   262   CONTINUE
  498.  2322 CONTINUE
  499. *     write(6,*) ' imik'
  500. *     write(6,*) ( imik(iu),iu=1,imik(/2))
  501. *     write(6,*) ' idua avant'
  502. *     write(6,*) ( idua(iu),iu=1,idua(/2))
  503.       nnn = idua(/2)
  504.       nqq = imik(/2)
  505.       if (nnn.ne.nqq) then
  506. *  on verra plus tard
  507.         call erreur(756)
  508.         return
  509.       endif
  510. * petit travail pour mettre dans le meme ordre les inconnues
  511.       segini mondu
  512.       do 476 iu=1,imik(/2)
  513.         lisi=imik(iu)
  514.         CALL PLACE(NOMDD,LNOMDD,idx,lisi)
  515.         IF (idx.NE.0) THEN
  516.           lisi=NOMDU(idx)
  517.         ENDIF
  518.         do 477 io=1,idua(/2)
  519.           if(idua(io).eq.lisi) go to 478
  520.  477    continue
  521.         inosel(iu)=1
  522.         go to 476
  523.  478    continue
  524.         mondua(iu)= idua(io)
  525.         ipris(io)=1
  526.  476  continue
  527.       do 472 iu=1,inosel(/1)
  528.         if (inosel(iu).eq.0) go to 472
  529.         do 473 io=1,ipris(/1)
  530.           if (ipris(io).eq.1) go to 473
  531.           ipris(io)=1
  532.           mondua(iu)=idua(io)
  533.           go to 472
  534.  473    continue
  535.  472  continue
  536.       do 479 iu=1,idua(/2)
  537.         idua(iu)=mondua(iu)
  538.  479  continue
  539.       segsup mondu
  540. *     write(6,*) ' idua apres'
  541. *     write(6,*) ( idua(iu),iu=1,idua(/2))
  542. C
  543.       MAXI=MAXDUA
  544.       SEGINI,MIPO1
  545.       maxt=max(maxinc,maxdua)
  546. C
  547. C  **** INITIALISATION DE INCPOS ET DE INCTRA.
  548. C
  549.  555  CONTINUE
  550.       SEGINI DIATMP,strv
  551.  
  552.       DO 29 IRI=1,NNVA
  553.         IHARIR=IRIGEL(5,IRI)
  554.         IF(IHARIR.EQ.NOHA ) IHARIR = IARDEF
  555.  
  556.         DESCR=IRIGEL(3,IRI)
  557.         NLIGRE=LISINC(/2)
  558.         NLIGRF=LISDUA(/2)
  559.         SEGINI,INCTRA
  560.         INCTRR(IRI)=INCTRA
  561.  
  562.         MELEME=IRIGEL(1,IRI)
  563.         N2=NUM(/2)
  564.  
  565.         XMATRI=IRIGEL(4,IRI)
  566.         SEGACT XMATRI
  567.  
  568.         DO 34 J=1,NLIGRE
  569.           DO 33 K=1,MAXINC
  570.             IF (IMIK(K).NE.LISINC(J)) GOTO 33
  571.             IF (IHAR(K).EQ.IHARIR)    GOTO 32
  572.  33       CONTINUE
  573.           CALL ERREUR(5)
  574. C
  575.  32       CONTINUE
  576.           INCTRA(J)=K
  577.           DO 31 I=1,N2
  578.             IJ=INUINV(NUM(NOELEP(J),I))
  579.             INCPO(K,IJ)=1
  580. *  terme diagonal
  581.             if ((bNONSYM.AND.(j.le.nligrf)).OR.(.NOT.bNONSYM))
  582.      &        diatmp(K,IJ)=diatmp(k,ij)+re(j,j,i)*coerig(iri)
  583.  31       continue
  584.  34     CONTINUE
  585.         SEGDES,INCTRA
  586.         IF (.NOT.bNONSYM) GOTO 30
  587. C
  588.         NLIGRF=LISINC(/2)
  589.         NLIGRE=LISDUA(/2)
  590.         SEGINI,INCTRA
  591.         INCTRS(IRI)=INCTRA
  592.  
  593.         DO 342 J=1,NLIGRE
  594.           DO 332 K=1,MAXDUA
  595.             IF (IDUA(K).NE.LISDUA(J))    GOTO 332
  596.             IF (MHAR1.IHAR(K).EQ.IHARIR) GOTO 322
  597.   332     CONTINUE
  598.           CALL ERREUR(5)
  599. C
  600.   322     CONTINUE
  601.           INCTRA(J)=K
  602.           DO  I=1,N2
  603.             IJ=INUINV(NUM(NOELED(J),I))
  604.             MIPO1.INCPO(K,IJ)=1
  605. *  terme diagonal
  606.             if (j.le.nligrf) diatmp(K,IJ)=diatmp(k,ij)+
  607.      >        re(j,j,i)*coerig(iri)
  608.           enddo
  609.   342   CONTINUE
  610.         SEGDES,INCTRA
  611. C
  612.  30     CONTINUE
  613.         SEGDES XMATRI
  614.  29   CONTINUE
  615. C
  616. C  ****  INITIALISATION DE IPOS
  617. C
  618.       IPOS(1)=0
  619.       NA=0
  620.       IF (bNONSYM) THEN
  621.         IPOSB(1)=0
  622.         ND=0
  623.       ENDIF
  624.       DO 37 I=1,NNOE
  625.         nad=na
  626.         diamax=0.d0
  627.         DO 35 K=1,MAXINC
  628.           IF(INCPO(K,I).EQ.0) GOTO 35
  629.           NA=NA+1
  630.           INCPO(K,I)=NA
  631.           itrv1(na-nad)=k
  632.           dtrv1(na-nad)= -diatmp(k,i)
  633.           diamax=max(diamax,abs(dtrv1(na-nad)))
  634.  35     CONTINUE
  635.         diaref = diamax * xszpre
  636.         do k=1,na-nad
  637.           if (abs(dtrv1(k)).lt.diaref) then
  638. **      write (6,*) ' terme diag petit ',dtrv1(k)
  639.             dtrv1(k)=dtrv1(k)+diamax
  640.           endif
  641.         enddo
  642. *  trier incpo suivant les val de diatmp
  643.         call triflo(dtrv1,dtrv2,itrv1,itrv2,na-nad)
  644.         do 351 k=1,na-nad
  645.           incpo(itrv1(k),i)=k+nad
  646.  351    continue
  647.         IPOS(I+1)=NA
  648. C
  649.         IF (.NOT.bNONSYM) GOTO 37
  650. C
  651.         ndd=nd
  652.         diamax=0.d0
  653.         DO 352 K=1,MAXDUA
  654.           IF(MIPO1.INCPO(K,I).NE.0) THEN
  655.             ND=ND+1
  656. C          ... MIPO1.INCPO(K,I) = numéro de l'équation ...
  657.             MIPO1.INCPO(K,I)=ND
  658.             itrv1(nd-ndd)=k
  659.             dtrv1(nd-ndd)= -diatmp(k,i)
  660.             diamax=max(diamax,abs(dtrv1(nd-ndd)))
  661.           ENDIF
  662.  352    CONTINUE
  663.         diaref = diamax * xszpre
  664.         do k=1,nd-ndd
  665.           if (abs(dtrv1(k)).lt.diaref) then
  666. **      write (6,*) ' terme diag petit ',dtrv1(k)
  667.             dtrv1(k)=dtrv1(k)+diamax
  668.           endif
  669.         enddo
  670.         call triflo(dtrv1,dtrv2,itrv1,itrv2,nd-ndd)
  671.         do k=1,nd-ndd
  672.           mipo1.incpo(itrv1(k),i)=k+ndd
  673.         enddo
  674.         IPOSB(I+1)=ND
  675.  37   CONTINUE
  676. C
  677.       DO IR=1,NNVA
  678.         MELEME=IRIGEL(1,IR)
  679.         DESCR =IRIGEL(3,IR)
  680.         SEGDES,MELEME,DESCR
  681.       ENDDO
  682. C
  683.       SEGDES,MIDUA,MIMIK,MHARK
  684. C
  685.       IF (bNONSYM) THEN
  686.         IF(NA.NE.ND) THEN
  687.           CALL ERREUR(756)
  688.           RETURN
  689.         ENDIF
  690. C
  691.         DO 567 IINO=1,NNOE1
  692.           IF (IPOS(IINO).NE.IPOSB(IINO)) THEN
  693.             WRITE(*,*) 'ERREUR dans ASNS1 !!! IPOS != IPOSB !!!'
  694.             RETURN
  695.           ENDIF
  696.  567    CONTINUE
  697.       ENDIF
  698. C
  699.       SEGINI,MMATRI
  700.       MMATRX=MMATRI
  701.       NENS=0
  702.       IGEOMA=IPT1
  703.       IIDUA=MIDUA
  704.       IINCPO=MINCPO
  705.       IIMIK=MIMIK
  706.       IHARK=MHARK
  707. C
  708.       INUINY=INUINV
  709.       ITOPOY=ITOPO
  710.       IPOY=IPOS
  711.       INCTRY=INCTRR
  712.       IITOPY=IITOP
  713.       SEGDES,ITOPO,IPOS,INCTRR,IITOP
  714.       SEGDES,MINCPO,MHARK
  715.       SEGSUP,IMIN
  716. C
  717.       IF (bNONSYM) THEN
  718.         IDUAPO=MIPO1
  719.         IHARDU=MHAR1
  720.         ITOPOD=ITOPOB
  721.         IPOD=IPOSB
  722.         INCTRD=INCTRS
  723.         IITOPD=IITOPB
  724.         SEGDES,ITOPOB,IPOSB,INCTRS,IITOPB
  725.         SEGDES,MIPO1,MHAR1
  726.         SEGSUP,IMINB
  727.       ENDIF
  728. C
  729.       SEGSUP,DIATMP,STRV
  730.       SEGDES,INUINV
  731.       SEGDES,MMATRI
  732.       SEGDES,MRIGID
  733.       END
  734.  
  735.  

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