Télécharger la plaquette Cast3M


fr en

Télécharger utum.eso

Retour à la liste

Numérotation des lignes : 

utum

  1. C UTUM      SOURCE    FANDEUR   22/01/03    21:15:55     11237          
  2.       SUBROUTINE UTUM(LCH1,IRIG1,DFLO,IRIG2)
  3. ************************************************************************
  4. * NOM         : UTUM
  5. ************************************************************************
  6. * DESCRIPTION : Realise le produit U*tU*M ou M est une matrice carree
  7. *               et U est une matrice rectangle dont les colonnes sont
  8. *               donnees par un objet LISTCHPO
  9. *
  10. *               - Les multiplicateurs de Lagrange sont ignores
  11. *               - Les harmoniques de Fourier differentes ne sont pas
  12. *                 croisees (matrice bloc-diagonale)
  13. *
  14. *               Les inconnues primales et duales de M doivent avoir
  15. *               ete definies dans les listes NOMDD et NOMDU et les
  16. *               composantes du LISTCHPO doivent avoir ete definies dans
  17. *               la liste NOMDD de l'include CCHAMP pour pour savoir
  18. *               comment effectuer la multiplication entre M et U*tU et
  19. *               comment nommer les inconnues duales de la matrice
  20. *            ***********************************************************  
  21. *
  22. *                                     +-----------+
  23. *                                     | CHPOINT#1 |
  24. *                                     +-----------+   +-----------+
  25. *                      tU[L;N] ---->  | CHPOINT#2 |   |           |
  26. *                                     +-----------+   |     M     |
  27. *                                     |    ...    |   |           |
  28. *                U[N;L]               +-----------+   |   [N;N]   |
  29. *                   |                 | CHPOINT#L |   |           |
  30. *                   |                 +-----------+   +-----------+
  31. *                   V                 
  32. *                 +---+---+---+---+   +-----------+   +-----------+
  33. *                 | C | C |   | C |   |           |   |           |
  34. *                 | H | H | . | H |   |    UTU    |   |   UTUM    |
  35. *                 | P | P | . | P |   |           |   |           |
  36. *                 | # | # | . | # |   |   [N;N]   |   |   [N;N]   |
  37. *                 | 1 | 2 |   | L |   |           |   |           |
  38. *                 +---+---+---+---+   +-----------+   +-----------+
  39. *
  40. *
  41. *                  avec :  L = nombre de champs
  42. *                          N = nombre d'inconnues
  43. *                              (triplet noeud/composante/harmonique)
  44. *
  45. ************************************************************************
  46. * APPELE PAR : pod.eso
  47. ************************************************************************
  48. * ENTREES :: LCH1  = POINTEUR VERS UN OBJET LISTCHPO
  49. *            IRIG1 = POINTEUR VERS UN OBJET RIGIDITE
  50. *            DFLO  = COEFFICIENT MULTIPLICATEUR
  51. * SORTIES :: IRIG2 = POINTEUR VERS UN OBJET RIGIDITE
  52. ************************************************************************    
  53.       IMPLICIT INTEGER(I-N)
  54.       IMPLICIT REAL*8 (A-H,O-Z)
  55.  
  56. -INC PPARAM
  57. -INC CCOPTIO
  58. -INC SMCOORD
  59. -INC SMCHPOI
  60. -INC SMLCHPO
  61. -INC SMELEME
  62. -INC SMRIGID
  63. -INC CCHAMP
  64. *
  65. *     ICPR(I) EST LE NUMERO LOCAL (DANS LE SUPPORT GEOMETRIQUE DU
  66. *     LISTCHPO LCH1) DU I-EME NOEUD GLOBAL (DANS LA TABLE XCOORD)
  67.       SEGMENT/TICPR/(ICPR(NOMAX))
  68. *
  69. *     TINCO(I) = [MCOMP(I) ; IHARM(I)]
  70. *     ********************************
  71. *     TINCO1 DEFINIT LES INCONNUES DE LA MATRICE IRIG1
  72. *     TINCO EST LE SOUS-ENSEMBLE DE TINCO1 DES INCONNUES COMMUNES A LA
  73. *     RIGIDITE IRIG1 ET AU LISTCHPO LCH1
  74. *     ********************************
  75. *     ICOMP(I) EST LE NUMERO DE LA COMPOSANTE (DANS LES LISTES NOMDD
  76. *              ET NOMDU) ASSOCIEE A LA I-EME INCONNUE
  77. *     IHARM(I) EST LE NUMERO D'HARMONIQUE DE LA I-EME INCONNUE
  78.       SEGMENT,ICOMP(0)
  79.       SEGMENT,IHARM(0)
  80.       SEGMENT,ICOMP1(0)
  81.       SEGMENT,IHARM1(0)
  82. *
  83. *     NUMHAR(I) EST LE NUMERO D'HARMONIQUE ASSOCIE A LA I-EME RIGIDITE
  84. *              ELEMENTAIRE DE LA MATRICE DE SORTIE IRIG2
  85. *     IMAHAR(I) EST LE POINTEUR VERS LE SEGMENT TIMAH ASSOCIE A LA I-EME
  86. *              RIGIDITE ELEMENTAIRE DE LA MATRICE DE SORTIE IRIG2
  87.       SEGMENT,NUMHAR(0)
  88.       SEGMENT,IMAHAR(0)
  89. *     IMAHA(I)=1 INDIQUE QUE LE I-EME NOEUD GLOBAL (DANS LA TABLE
  90. *     XCOORD) APPARTIENT AU MAILLAGE LOCAL DE LA RIGIDITE ELEMENTAIRE
  91. *     CORRESPONDANTE
  92.       SEGMENT/TIMAH/(IMAHA(NOMAX))
  93. *
  94. *     IMAI(I) EST LE MAILLAGE ASSOCIE AU I-EME SOUPO DU PREMIER CHPOINT
  95. *     IPOV(I,J) EST LE MPOVAL DU SOUPO DU J-EME CHPOINT QUI CORRESPOND
  96. *               AU I-EME SOUPO DU PREMIER CHPOINT (IPOV=0 SI LE SOUPO
  97. *               EST ASSOCIE AUX MULT. DE LAGRANGE)
  98. *     L'INCONNUE I DU SOUPO J DU PREMIER CHPOINT EST EN POSITION
  99. *     IINC(I,J,K) DANS LE SOUPO CORRESPONDANT DU K-EME CHPOINT
  100. *     L'INCONNUE I DU SOUPO J DU PREMIER CHPOINT EST EN POSITION
  101. *     IGLO(I,J) DANS LA LISTE GLOBALE ICOMP+IHARM
  102.       SEGMENT TRAV1
  103.          INTEGER IMAI(NBSOU)
  104.          INTEGER IPOV(NBSOU,NBCHP)
  105.          INTEGER IINC(NXMAX,NBSOU,NBCHP)
  106.          INTEGER IGLO(NXMAX,NBSOU)
  107.       ENDSEGMENT
  108. *
  109. *     VPO(I,J,K) EST LA VALEUR DU K-EME CHPOINT PRISE POUR LE I-EME
  110. *                NOEUD LOCAL ET POUR LA J-EME INCONNUE DE TINCO
  111. *     MAT(I,J,K,L) EST LA MATRICE U*tU AVEC I (RESP. K) LE NOEUD LOCAL
  112. *                  DUAL (RESP. PRIMAL) ET J (RESP. L) L'INCONNUE DUALE
  113. *                  (RESP. PRIMALE) PRISE DANS TINCO
  114.       SEGMENT TRAV2
  115.          REAL*8 VPO(NBPOI,NBINC,NBCHP)
  116.          REAL*8 MAT(NBPOI,NBINC,NBPOI,NBINC)
  117.       ENDSEGMENT
  118. *
  119. *     IPOSP(I) DONNE LA POSITION DANS TINCO DE LA I-EME INCONNUE PRIMALE
  120. *              D'UNE MATRICE ELEMENTAIRE
  121. *     IPOSD(I) DONNE LA POSITION DANS TINCO DE LA I-EME INCONNUE DUALE
  122. *              D'UNE MATRICE ELEMENTAIRE
  123.       SEGMENT TPOSIN
  124.          INTEGER IPOSP(NLIGRE)
  125.          INTEGER IPOSD(NLIGRE)
  126.       ENDSEGMENT
  127. *     ITPOS(I) EST LE POINTEUR VERS LE SEGMENT TPOSIN ASSOCIE A LA I-EME
  128. *              RIGIDITE ELEMENTAIRE DE LA MATRICE D'ENTREE IRIG1
  129.       SEGMENT/IPOSIN/(ITPOS(NRIGEL1))
  130. *
  131. *     IG2L(I,J) EST L'INDICE DE INCONNUE LOCALE D'UNE SOUS-MATRICE DE
  132. *               IRIG2 ASSOCIEE AU NOEUD I ET A L'INCONNUE J DANS TINCO
  133. *     IL2G(I) EST L'INDICE DANS TINCO DE LA I-EME INCONNUE LOCALE D'UNE
  134. *             SOUS-MATRICE DE IRIG2
  135.       SEGMENT/TIG2L/(IG2L(NBPOI,NBINC))
  136.       SEGMENT/TIL2G/(IL2G(NLIGRE))
  137. *
  138.       CHARACTER*(LOCOMP) MOCOMP
  139. *
  140. *
  141. *
  142. *     +---------------------------------------------------------------+ 
  143. *     |                                                               |
  144. *     |            T R A V A I L   P R E L I M I N A I R E            |
  145. *     |                                                               |
  146. *     +---------------------------------------------------------------+
  147. *
  148.       MLCHPO=LCH1                                                               
  149.       SEGACT,MLCHPO  
  150. *      
  151. *
  152. *     ==========================================================
  153. *     CONSTRUCTION DE LA LISTE DES INCONNUES DE LA MATRICE IRIG1
  154. *     (= COUPLE NOM_DE_COMPOSANTE_PRIMALE + NUMERO_HARMONIQUE)
  155. *     ==========================================================
  156. *
  157.       NOMAX=nbpts
  158.       SEGINI,ICOMP1,IHARM1,NUMHAR,IMAHAR
  159.       NBHAR=0
  160.       NBINC1=0
  161. *
  162.       MRIGID=IRIG1
  163.       SEGACT,MRIGID
  164.       NRIGEL1=IRIGEL(/2)
  165. *
  166. *
  167. *     BOUCLE SUR LES RIGIDITES ELEMENTAIRES
  168.       DO IRI1=1,NRIGEL1
  169. *
  170. *        IDENTIFICATION DES HARMONIQUES DE FOURIER DISTINCTES DANS IRIG1
  171.          IHA=IRIGEL(5,IRI1)
  172.          DO 10 K=1,NBHAR
  173.             IF (IHA.EQ.NUMHAR(K)) THEN
  174.                TIMAH=IMAHAR(K)
  175.                GOTO 11
  176.             ENDIF
  177.   10     CONTINUE
  178.          NBHAR=NBHAR+1
  179.          NUMHAR(**)=IHA
  180.          SEGINI,TIMAH
  181.          IMAHAR(**)=TIMAH
  182.   11     CONTINUE
  183. *        
  184. *        CONSTRUCTION DU MAILLAGE SUPPORT DE CHAQUE HARMONIQUE DE IRIG1
  185. *        => IMAHA(K)=1 INDIQUE QUE LE NOEUD GLOBAL K EST DANS LE SUPPORT
  186.          MELEME=IRIGEL(1,IRI1)
  187.          SEGACT,MELEME
  188.          NNO=NUM(/1)
  189.          NEL=NUM(/2)
  190.          DO IEL=1,NEL
  191.             DO 12 INO=1,NNO
  192.                K1=NUM(INO,IEL)
  193.                IMAHA(K1)=1
  194.   12        CONTINUE
  195.          ENDDO
  196. *        
  197. *        CONSTRUCTION DE LA LISTE DES INCONNUES DE LA MATRICE IRIG1
  198.          DESCR=IRIGEL(3,IRI1)
  199.          SEGACT,DESCR
  200.          NLIGRE=LISDUA(/2)
  201.          DO 15 IX1=1,NLIGRE
  202.  
  203. *           RECHERCHE DE L'INDICE DE LA COMPOSANTE DANS LNOMDU (LISTE
  204. *           GLOBALE DES COMPOSANTES DUALES)
  205.             MOCOMP=LISDUA(IX1)
  206.             DO IXD=1,LNOMDU
  207.                IF (MOCOMP.EQ.NOMDU(IXD)) GOTO 13
  208.             ENDDO
  209.             MOTERR=MOCOMP
  210.             CALL ERREUR(108)
  211.             RETURN
  212.   13        CONTINUE
  213.  
  214. *           AJOUT SI BESOIN D'UNE NOUVELLE INCONNUE A ICOMP1+IHARM1
  215.             DO 14 IX2=1,NBINC1
  216.                IF (IXD.NE.ICOMP1(IX2)) GOTO 14
  217.                IF (IHA.EQ.IHARM1(IX2)) GOTO 15
  218.   14        CONTINUE
  219.             ICOMP1(**)=IXD
  220.             IHARM1(**)=IHA
  221.             NBINC1=NBINC1+1
  222.  
  223.   15     CONTINUE
  224.  
  225.       ENDDO
  226. *
  227. *
  228. *     ===================================
  229. *     NOMBRE DE CHPOINTS DANS LE LISTCHPO
  230. *     ===================================
  231. *
  232.       NBCHP=ICHPOI(/1)
  233.       IF (NBCHP.EQ.0) THEN
  234.          MOTERR(1:8)='LISTCHPO'
  235.          INTERR(1)=LCH1
  236.          CALL ERREUR(356)
  237.          RETURN
  238.       ENDIF
  239. *
  240. *
  241. *     ===============================================================
  242. *     CORRESPONDANCE ENTRE LES INCONNUES DU PREMIER CHPOINT ET CELLES
  243. *     DES CHPOINTS SUIVANTS + CORRESPONDANCE AVEC LA LISTE GLOBALE
  244. *     ICOMP1+IHARM1 DES INCONNUES DE LA MATRICE (REMPLISSAGE DE TRAV1)
  245. *     CORRESPONDANCE ENTRE LES NUMEROTATIONS LOCALE ET GLOBALE
  246. *     (REMPLISSAGE DE ICPR)
  247. *     ===============================================================
  248. *
  249.       MCHPO1=ICHPOI(1)
  250.       SEGACT,MCHPO1
  251. *
  252.       NS1=MCHPO1.IPCHP(/1)
  253.       IF (NS1.EQ.0) THEN
  254.          MOTERR(1:8)='CHPOINT'
  255.          CALL ERREUR(1027)
  256.          RETURN
  257.       ENDIF
  258. *
  259.       NOMAX=nbpts
  260.       SEGINI,TICPR
  261.       NBPOI=0
  262. *
  263.       SEGINI,ICOMP,IHARM
  265. *
  266.       NXMAX=3
  267.       NBSOU=NS1
  268.       SEGINI,TRAV1
  269. *  
  270. *
  271. *     **************************************
  272. *     BOUCLE 1 SUR LES SOUPOS DU 1ER CHPOINT
  273. *     **************************************
  274.       DO 20 IS1=1,NS1              
  275.          MSOUP1=MCHPO1.IPCHP(IS1)                                                   
  276.          SEGACT,MSOUP1
  277. *
  278. *        ON IGNORE LES MULTIPLICATEURS DE LAGRANGE
  279.          NX1   =MSOUP1.NOCOMP(/2)
  280.          MOCOMP=MSOUP1.NOCOMP(1)
  281.          IF (MOCOMP.EQ.'LX'.OR.MOCOMP.EQ.'FLX') THEN
  282.             SEGDES,MSOUP1
  283.             GOTO 20
  284.          ENDIF
  285. *
  286.          IF (NX1.GT.NXMAX) THEN
  287.             NXMAX=NX1
  288.             SEGADJ,TRAV1
  289.          ENDIF
  290. *
  291. *        DANS ICOMP+IHARM, ON PLACE LES INCONNUES DU LISTCHPO QUI
  292. *        EXISTENT DEJA DANS ICOMP1+IHARM1 (DONC DANS LA MATRICE IRIG1)
  293.          DO 21 IX1=1,NX1
  294.  
  295. *           RECHERCHE DE L'INDICE DE LA COMPOSANTE DANS LNOMDD (LISTE
  296. *           GLOBALE DES COMPOSANTES PRIMALES)
  297.             MOCOMP=MSOUP1.NOCOMP(IX1)
  298.             IINC(IX1,IS1,1)=IX1
  299.             DO IC1=1,LNOMDD
  300.                IF (MOCOMP.EQ.NOMDD(IC1)) GOTO 22
  301.             ENDDO
  302.             MOTERR=MOCOMP
  303.             CALL ERREUR(108)
  304.             RETURN
  305.   22        CONTINUE
  306.  
  307. *           AJOUT SI BESOIN D'UNE NOUVELLE INCONNUE A ICOMP+IHARM
  308.             NOHA=MSOUP1.NOHARM(IX1)
  309.             DO 23 IX2=1,NBINC1
  310.                IF (IC1.NE.ICOMP1(IX2))  GOTO 23
  311.                IF (NOHA.NE.IHARM1(IX2)) GOTO 23
  312.                DO 24 IX3=1,NBINC
  313.                   IF (IC1.NE.ICOMP(IX3))  GOTO 24
  314.                   IF (NOHA.EQ.IHARM(IX3)) GOTO 21
  315.   24           CONTINUE
  317.                ICOMP(**)=IC1
  318.                IHARM(**)=NOHA
  319.                IGLO(IX1,IS1)=NBINC
  320.   23        CONTINUE
  321.  
  322.   21     CONTINUE
  323. *
  324. *        ON VERIFIE QUE LE MAILLAGE N'EST PAS VIDE
  325.          IGEO1=MSOUP1.IGEOC
  326.          IF (IGEO1.LE.0) THEN
  327.             MOTERR(1:8)='CHPOINT'
  328.             CALL ERREUR(1027)
  329.             RETURN
  330.          ENDIF
  331.          IMAI(IS1)=IGEO1
  332.          IPT1=IGEO1
  333.          SEGACT,IPT1
  334.          NNO1=IPT1.NUM(/2)
  335.          IF (NNO1.EQ.0) GOTO 20
  336. *
  337. *        CONSTRUCTION DE LA TABLE ICPR
  338. *        (NUMEROTATION GLOBALE <=> LOCALE)
  339.          DO 25 I1=1,NNO1
  340.             K1=IPT1.NUM(1,I1)
  341.             IF (ICPR(K1).NE.0) GOTO 25
  342.             NBPOI=NBPOI+1
  343.             ICPR(K1)=NBPOI
  344.   25     CONTINUE
  345.          SEGDES,IPT1
  346. *
  347. *        POINTEUR DIRECT VERS LE SEGMENT MPOVAL
  348.          IPOV(IS1,1)=MSOUP1.IPOVAL
  349. *
  350. *
  351. *        ********************************
  352. *        BOUCLE 2 SUR LES AUTRES CHPOINTS
  353. *        ********************************
  354.          DO 26 ICH=2,NBCHP
  355.             MCHPO2=ICHPOI(ICH)
  356.             SEGACT,MCHPO2
  357.             NS2=MCHPO2.IPCHP(/1)         
  358. *           
  359. *           **********************************************
  360. *           ON VA CHERCHER LE SOUPO CORRESPONDANT A MSOUP1
  361. *           => BOUCLE 3 SUR LES SOUPOS DE MCHPO2
  362. *           **********************************************
  363.             DO 27 IS2=1,NS2                                                           
  364.                MSOUP2=MCHPO2.IPCHP(IS2)                                                   
  365.                SEGACT,MSOUP1,MSOUP2
  366. *
  367. *              MEME MAILLAGE ?
  368.                IGEO2=MSOUP2.IGEOC
  369.                IF (IGEO1.NE.IGEO2) THEN
  370.                   SEGDES,MSOUP2
  371.                   GOTO 27
  372.                ENDIF
  373. *
  374. *              MEME NOMBRE DE COMPOSANTES ?
  375.                NX2   =MSOUP2.NOCOMP(/2)
  376.                MOCOMP=MSOUP1.NOCOMP(1)
  377.                IF (MOCOMP.EQ.'LX'.OR.MOCOMP.EQ.'FLX'.OR.NX1.NE.NX2) THEN
  378.                   SEGDES,MSOUP2
  379.                   GOTO 27
  380.                ENDIF
  381.                IF (NX2.GT.NXMAX) THEN
  382.                   NXMAX=NX2
  383.                   SEGADJ,TRAV1
  384.                ENDIF
  385. *
  386. *              MEMES LISTES DE COMPOSANTES ?
  387. *              => ON FAIT LA CORRESPONDANCE ENTRE LES COMPOSANTES DES
  388. *                 2 SOUPOS
  389.                DO 28 IX1=1,NX1
  390.                   MOCOMP=MSOUP1.NOCOMP(IX1)
  391.                   DO 29 IX2=1,NX2
  392.                      IF (MOCOMP.NE.MSOUP2.NOCOMP(IX2)) GOTO 29
  393.                      IF (MSOUP1.NOHARM(IX1).EQ.MSOUP2.NOHARM(IX2)) THEN
  394.                         IINC(IX1,IS1,ICH)=IX2
  395.                         GOTO 28
  396.                      ENDIF
  397.   29              CONTINUE
  398.                   GOTO 99
  399.   28           CONTINUE
  400. *
  401. *              POINTEUR DIRECT VERS LE SEGMENT MPOVAL
  402.                IPOV(IS1,ICH)=MSOUP2.IPOVAL
  403.  
  404. *              (CHPOINT SUIVANT)
  405.                SEGDES,MSOUP2,MCHPO2
  406.                GOTO 26
  407. *
  408.   27        CONTINUE
  409. *                                                                                     
  410. *           MESSAGE D'ERREUR                                                          
  411. *           ****************
  412.   99        CONTINUE
  413.             WRITE(MOTERR(1:16),FMT='(2I8)') MCHPO1,MCHPO2
  414.             CALL ERREUR(135)                                                          
  415.             RETURN                                                                                                                          
  416. *        
  417.   26     CONTINUE
  418.          SEGDES,MSOUP1
  419. *
  420.   20  CONTINUE
  421.       SEGDES,MCHPO1,MLCHPO
  422.       SEGSUP,ICOMP1,IHARM1
  423. *
  424. *
  425. *     ========================================================
  426. *     STOCKAGE DES VALEURS DU LISTCHPO DANS UN TABLEAU ORDONNE
  427. *     SELON LA GEOMETRIE LOCALE (ICPR) ET SELON LES INCONNUES
  428. *     DE TINCO => REMPLISSAGE DE TRAV2
  429. *     ========================================================
  430. *
  431.       SEGINI,TRAV2
  432.       DO ICH=1,NBCHP
  433.          DO 30 ISOU=1,NBSOU
  434.             IPO1=IPOV(ISOU,ICH)
  435.             IF (IPO1.EQ.0) GOTO 30
  436.             MPOVAL=IPO1
  437.             SEGACT,MPOVAL
  438.             NNO=VPOCHA(/1)
  439.             NIX=VPOCHA(/2)
  440.             MELEME=IMAI(ISOU)
  441.             SEGACT,MELEME
  442.             DO 31 IX=1,NIX
  443.                IX1=IGLO(IX,ISOU)
  444.                IF (IX1.EQ.0) GOTO 31
  445.                IIX=IINC(IX,ISOU,ICH)
  446.                DO INO=1,NNO
  447.                   N1=ICPR(NUM(1,INO))
  448.                   VPO(N1,IX1,ICH)=VPOCHA(INO,IIX)
  449.                ENDDO
  450.   31        CONTINUE
  451.             SEGDES,MELEME,MPOVAL
  452.   30     CONTINUE
  453.       ENDDO
  454.       SEGSUP,TRAV1   
  455. *
  456. *
  457. *     =========================   
  458. *     CALCUL DE LA MATRICE U*tU
  459. *     =========================
  460. *
  461.       DO IX1=1,NBINC            
  462.          DO IN1=1,NBPOI
  463.             DO 40 IX2=1,NBINC
  464.                IF (IHARM(IX2).NE.IHARM(IX1)) GOTO 40
  465.                DO IN2=1,NBPOI
  466.                   XVAL=0.D0
  467.                   DO ICH=1,NBCHP
  468.                      VA1=VPO(IN1,IX1,ICH)
  469.                      VA2=VPO(IN2,IX2,ICH)
  470.                      XVAL=XVAL+VA1*VA2
  471.                   ENDDO
  472.                   MAT(IN2,IX2,IN1,IX1)=XVAL
  473.                ENDDO
  474.   40        CONTINUE  
  475.          ENDDO
  476.       ENDDO
  477. *
  478. *     REMPLISSAGE DU TRIANGLE INFERIEUR
  479.       DO IX1=1,NBINC
  480.          DO IN1=1,NBPOI
  481.             DO 50 IX2=IX1+1,NBINC
  482.                IF (IHARM(IX2).NE.IHARM(IX1)) GOTO 50
  483.                DO IN2=1,NBPOI
  484.                   MAT(IN2,IX2,IN1,IX1)=MAT(IN1,IX1,IN2,IX2)
  485.                ENDDO
  486.   50        CONTINUE  
  487.          ENDDO
  488.       ENDDO
  489. *
  490. *
  491. *     ============================================================
  492. *     POUR CHAQUE SOUS-MATRICE ON REPERE LA POSITION DES INCONNUES
  493. *     LOCALES AU SEIN DES LISTES GLOBALES ICOMP+IHARM
  494. *     ============================================================
  495. *
  496.       SEGINI,IPOSIN
  497. *
  498.       DO IRI1=1,NRIGEL1
  499. *
  500.          IHA=IRIGEL(5,IRI1)
  501. *
  502.          DESCR=IRIGEL(3,IRI1)
  503.          SEGACT,DESCR
  504.          NINCP=LISINC(/2)
  505.          NINCD=LISDUA(/2)
  506. *
  507. *        ON VERIFIE QUE LA MATRICE EST CARREE
  508.          IF (NINCP.NE.NINCD) THEN
  509.             CALL ERREUR(21)
  510.             RETURN
  511.          ENDIF
  512. *
  513.          NLIGRE=NINCD
  514.          SEGINI,TPOSIN
  515.          ITPOS(IRI1)=TPOSIN
  516. *
  517. *        CORRESPONDANCE ENTRE LES INCONNUES DUALES DE LA MATRICE
  518. *        ELEMENTAIRE ET LES INCONNUES GLOBALES DES SEGMENTS ICOMP+IHARM
  519.          DO 60 ICO=1,NINCD
  520.             MOCOMP=LISDUA(ICO)
  521.             DO ICOD=1,LNOMDU
  522.                IF (MOCOMP.EQ.NOMDU(ICOD)) GOTO 61
  523.             ENDDO
  524.   61        CONTINUE
  525.             DO 62 IX=1,NBINC
  526.                IF (ICOD.NE.ICOMP(IX)) GOTO 62
  527.                IF (IHA.NE.IHARM(IX)) GOTO 62
  528.                IPOSD(ICO)=IX
  529.                GOTO 60
  530.   62        CONTINUE
  531.   60     CONTINUE
  532. *        
  533. *        CORRESPONDANCE ENTRE LES INCONNUES PRIMALES DE LA MATRICE
  534. *        ELEMENTAIRE ET LES INCONNUES "GLOBALES" DU SEGMENT TINCO
  535. *        L'ASSOCIATION EST FAITE GRACE AUX LISTES DEFINIES DANS
  536. *        L'INCLUDE CCHAMP
  537.          DO 70 ICO=1,NINCP
  538.             MOCOMP=LISINC(ICO)
  539.             DO ICOP=1,LNOMDD
  540.                IF (MOCOMP.EQ.NOMDD(ICOP)) GOTO 71
  541.             ENDDO
  542.             MOTERR=MOCOMP
  543.             CALL ERREUR(108)
  544.             RETURN
  545.   71        CONTINUE
  546.             DO 72 IX=1,NBINC
  547.                IF (ICOP.NE.ICOMP(IX)) GOTO 72
  548.                IF (IHA.NE.IHARM(IX)) GOTO 72
  549.                IPOSP(ICO)=IX
  550.                GOTO 70
  551.   72        CONTINUE
  552.  
  553.             CALL ERREUR(21)
  554.             RETURN
  555.   70     CONTINUE
  556. *
  557.       ENDDO      
  558. *
  559. *
  560. *
  561. *     +---------------------------------------------------------------+ 
  562. *     |                                                               |
  563. *     |          C R E A T I O N   D E   L A   M A T R I C E          |
  564. *     |                                                               |
  565. *     +---------------------------------------------------------------+
  566. *
  567. *
  568. *     =================
  569. *     CHAPEAU DU MRIGID
  570. *     =================
  571. *
  572. *     ON VA CREER AUTANT DE SOUS-MATRICES QU'IL Y A D'HARMONIQUES
  573. *     DE FOURIER DISTINCTES
  574.       NRIGEL=NBHAR
  575.       SEGINI,RI2
  576.       IRIG2=RI2
  577.       RI2.MTYMAT='RIGIDITE'
  578.       RI2.COERIG(1)=DFLO
  579.       RI2.ICHOLE=0
  580.       RI2.IMGEO1=0
  581.       RI2.IMGEO2=0
  582.       RI2.IFORIG=IFOUR
  583.       RI2.ISUPEQ=0
  584.       RI2.JRCOND=0
  585.       RI2.JRDEPP=0
  586.       RI2.JRDEPD=0
  587.       RI2.JRELIM=0
  588.       RI2.JRGARD=0
  589.       RI2.JRTOT=0
  590.       RI2.IMLAG=0
  591.       RI2.IVECRI=0 
  592. *
  593. *     BOUCLE 1 SUR LES SOUS-MATRICES DE LA MATRICE RESULTAT IRIG2
  594. *     ***********************************************************
  595.       IHA2=0
  596.       DO 80 IRI2=1,NBHAR
  597. *
  598.          NOHA2=NUMHAR(IRI2)
  599. *
  600. *        =========================
  601. *        CREATION DU SUPER-ELEMENT
  602. *        =========================
  603. *
  604.          NBSOUS=0
  605.          NBELEM=1
  606.          NBNN=NBPOI
  607.          NBREF=0
  608.          SEGINI,IPT2
  609.          IPT2.ITYPEL=28
  610. *
  611. *        ON RETIENT LES NOEUDS QUI SONT A LA FOIS DANS M ET DANS U
  612.          TIMAH=IMAHAR(IRI2)
  613.          NBNN=0
  614.          DO K=1,NOMAX
  615.             IF (IMAHA(K).NE.0.AND.ICPR(K).NE.0) THEN
  616.                NBNN=NBNN+1
  617.                IPT2.NUM(NBNN,1)=K           
  618.             ENDIF
  619.          ENDDO
  620.          SEGSUP,TIMAH
  621. *
  622.          IF (NBNN.EQ.0) THEN
  623.             SEGSUP,IPT2
  624.             GOTO 80
  625.          ENDIF
  626. *
  627.          SEGADJ,IPT2
  628. *
  629.          IHA2=IHA2+1
  630. *
  631. *
  632. *        =========================
  633. *        DESCRIPTEUR DE LA MATRICE
  634. *        =========================
  635. *        
  636.          NLIGRE=NBINC*NBPOI
  637.          NLIGRP=NLIGRE
  638.          NLIGRD=NLIGRE
  639.          SEGINI,DES2,TIG2L,TIL2G
  640.          NLIGRE=0
  641.          DO 81 IX=1,NBINC
  642.             IF (IHARM(IX).NE.NOHA2) GOTO 81
  643.             DO IN=1,NBNN
  644.                NLIGRE=NLIGRE+1
  645.                DES2.LISINC(NLIGRE)=NOMDD(ICOMP(IX))
  646.                DES2.LISDUA(NLIGRE)=NOMDU(ICOMP(IX))
  647.                DES2.NOELEP(NLIGRE)=IN
  648.                DES2.NOELED(NLIGRE)=IN
  649.                IN1=ICPR(IPT2.NUM(IN,1))
  650.                IG2L(IN1,IX)=NLIGRE
  651.                IL2G(NLIGRE)=IX
  652.             ENDDO
  653.   81     CONTINUE
  654.          NLIGRP=NLIGRE
  655.          NLIGRD=NLIGRE
  656.          SEGADJ,DES2,TIL2G
  657. *        
  658. *        
  659. *        ======================
  660. *        REMPLISSAGE DU CONTENU
  661. *        ======================
  662. *
  663.          NELRIG=1
  664.          SEGINI,XMATR2
  665. *
  666. *        BOUCLE 2 SUR LES SOUS-MATRICES DE LA MATRICE D'ENTREE IRIG1
  667. *        ***********************************************************
  668.          DO 82 IRI1=1,NRIGEL1
  669. *
  670.             COER=COERIG(IRI1)
  671. *
  672.             NOHA1=IRIGEL(5,IRI1)
  673.             IF (NOHA1.NE.NOHA2) GOTO 82
  674. *
  675.             MELEME=IRIGEL(1,IRI1)
  676.             SEGACT,MELEME
  677.             IF (ITYPEL.EQ.22) THEN
  678.                SEGDES,MELEME
  679.                GOTO 82
  680.             ENDIF
  681.             NNO=NUM(/1)
  682.             NEL=NUM(/2)
  683. *
  684.             DESCR=IRIGEL(3,IRI1)
  685.             SEGACT,DESCR
  686.             NINCP=LISINC(/2)
  687.             NINCD=LISDUA(/2)
  688.             TPOSIN=ITPOS(IRI1)
  689.             SEGACT,TPOSIN
  690. *
  691.             XMATRI=IRIGEL(4,IRI1)
  692.             SEGACT,XMATRI
  693. *
  694. *           BOUCLE 3 SUR LES ELEMENTS DE LA SOUS-MATRICE [M].IRI1
  695. *           *****************************************************
  696.             DO 83 IEL=1,NEL
  697. *
  698. *              ON VERIFIE QUE LA RIGIDITE ELEMENTAIRE POSSEDE UN
  699. *              SUPPORT GEOMETRIQUE COMPATIBLE AVEC LE LISTCHPO
  700.                DO INO=1,NNO
  701.                   IF (ICPR(NUM(INO,IEL)).NE.0) GOTO 84
  702.                ENDDO
  703.                GOTO 83
  704. *
  705.   84           CONTINUE
  706. *
  707. *              BOUCLE 4 SUR LES PRIMALES (= COLONNES) DE [M].IRI1.IEL
  708. *              ******************************************************
  709.                DO 85 IXP=1,NINCP
  710.                   IN1=ICPR(NUM(NOELEP(IXP),IEL))
  711.                   IF (IN1.EQ.0) GOTO 85
  712.                   IX1=IPOSP(IXP)
  713.                   IF (IX1.EQ.0) GOTO 85
  714.                   ICOL=IG2L(IN1,IX1)
  715. *
  716. *                 BOUCLE 5 SUR TOUTES LES DUALES (= LIGNES) DE [U*tU]
  717. *                 ***************************************************
  718.                   DO ILIG=1,NLIGRE
  719.                      IX2=IL2G(ILIG)
  720.                      IN2=ICPR(IPT2.NUM(DES2.NOELED(ILIG),1))
  721. *
  722. *                    BOUCLE 6 SUR LES DUALES (= LIGNES) [M].IRI1.IEL ET
  723. *                    ET LES PRIMALES (= COLONNES) ASSOCIEES DANS [U*tU]                                
  724. *                    **************************************************
  725.                      XVAL=0.D0                     
  726.                      DO 86 IXD=1,NINCD
  727.                         IN3=ICPR(NUM(NOELED(IXD),IEL))
  728.                         IF (IN3.EQ.0) GOTO 86
  729.                         IX3=IPOSD(IXD)
  730.                         IF (IX3.EQ.0) GOTO 86
  731. *
  732.                         VA1=RE(IXD,IXP,IEL)
  733.                         VA2=MAT(IN2,IX2,IN3,IX3)
  734. *
  735.                         XVAL=XVAL+VA1*VA2
  736.   86                 CONTINUE
  737. *
  738.                      XMATR2.RE(ILIG,ICOL,1)=XMATR2.RE(ILIG,ICOL,1)
  739.      &                                     +XVAL*COER
  740. c      
  741. *
  742.                   ENDDO
  743.   85           CONTINUE
  744.   83        CONTINUE
  745.             IF (IRI2.EQ.NBHAR) SEGDES,MELEME,DESCR,XMATRI
  746.   82     CONTINUE
  747. *
  748.          RI2.IRIGEL(1,IHA2)=IPT2
  749.          RI2.IRIGEL(2,IHA2)=0
  750.          RI2.IRIGEL(3,IHA2)=DES2
  751.          RI2.IRIGEL(4,IHA2)=XMATR2
  752.          RI2.IRIGEL(5,IHA2)=NOHA2
  753.          RI2.IRIGEL(6,IHA2)=0
  754. *        AUCUNE RAISON A PRIORI QUE IRIG2 SOIT SYMETRIQUE
  755.          RI2.IRIGEL(7,IHA2)=2
  756.          xmatr2.symre=2
  757. *
  758.          SEGDES,DES2,XMATR2,IPT2
  759.          SEGSUP,TIG2L,TIL2G
  760. *
  761.   80  CONTINUE
  762. *
  763. *     UN PEU DE MENAGE...
  764.       SEGDES,MRIGID,RI2
  765.       SEGSUP,TRAV2,ICOMP,IHARM,NUMHAR,IMAHAR,TICPR
  766.       DO IRI=1,NRIGEL1
  767.          TPOSIN=ITPOS(IRI)
  768.          SEGSUP,TPOSIN
  769.       ENDDO
  770.       SEGSUP,IPOSIN
  771. *
  772. *
  773.       RETURN
  774. *
  775.       END
  776. *
  777. * 
  778.  
  779.  
  780.  
  781.  
  782.  
  783.  
  784.  

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