Télécharger la plaquette Cast3M


fr en

Télécharger qzcon1.eso

Retour à la liste

Numérotation des lignes : 

qzcon1

  1. C QZCON1    SOURCE    PV090527  26/04/30    21:16:02     12529          
  2. *
  3. * creation : bp,2022-09-15         
  4. * inspiré de : QZCONS    SOURCE    PV        20/03/24    21:21:13     10554
  5. *
  6. **********************************************************************************
  7. *   EN ENTREE :                                                                  *
  8. *      - RI1 : matrice A (non assemblee)                                         *
  9. *                                                                                *
  10. *   EN SORTIE :                                                                  *
  11. *      - XMATR1, XMATR2 : les matrices assemblees A et B nxn                     *
  12. *        A = A    B = I                                                          *
  13. *                                                                                *
  14. *      - MELEME : le maillage support                                            *
  15. *      - MLMOTS : les composantes (ALFA suelement meme si non coherent !)        *
  16. **********************************************************************************
  17. *
  18.       SUBROUTINE QZCON1(RI1,XMATR1,XMATR2,MELEME,MLMOTS)
  19.       IMPLICIT INTEGER(I-N)
  20.       IMPLICIT REAL*8 (A-H,O-Z)
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMELEME
  25. -INC SMLMOTS
  26. -INC SMRIGID
  27. -INC SMCOORD
  28.  
  29.       SEGMENT ICPR(nbpts)
  30.       SEGMENT KDDL(NK)
  31.       SEGMENT KINCO(JGM,NINCO)
  32.       POINTEUR XMATRM.XMATRI
  33.  
  34.       LOGICAL AFFICH
  35.       CHARACTER*4 MOPRI,MODUA
  36.       PARAMETER(NDDMAX=400)
  37.  
  38. *     Affichage des messages pour verification
  39.       AFFICH = IIMPI.GE.21
  40.  
  41.  
  42. *======================================================================*
  43. *     INITIALISATIONS
  44. *======================================================================*
  45.  
  46. *     du MELEME
  47.       NBREF=0
  48.       NBSOUS=0
  49.       NBELEM=20
  50.       NBNN=1
  51.       SEGINI,MELEME
  52.  
  53. *     du MLMOTS
  54.       JGN=4
  55.       JGM=NBELEM
  56.       SEGINI,MLMOTS
  57.  
  58. *     de XMATR1 XMATR2
  59.       NELRIG=1
  60.       NLIGRD=NBELEM
  61.       NLIGRP=NLIGRD
  62.       rigrel=0
  63.       SEGINI,XMATR1,XMATR2
  64.  
  65. *     de ICPR = tableau de la numerotation locale
  66.       SEGACT MCOORD*mod
  67.       SEGINI,ICPR
  68.       NLOC=0
  69.  
  70. *     de MLMOT1 = tableau des noms d'inconnue locale
  71.       JGN=4
  72.       JGM=10
  73.       SEGINI,MLMOT1
  74.       JGM1=0
  75.  
  76. *     de KINCO = tableau des ddls
  77.       NINCO=10
  78.       SEGINI KINCO
  79.  
  80. *     nombre total de DDL :      
  81.       NDDL=0
  82.  
  83.  
  84. *======================================================================*
  85. *     RIGIDITE en entree
  86. *======================================================================*
  87.  
  88.         MRIGID=RI1
  89.         IF(MRIGID.EQ.0) CALL ERREUR(5)
  90.  
  91.         SEGACT,MRIGID
  92.         NRIGEL=IRIGEL(/2)
  93.  
  94. *======================================================================*
  95. *       BOUCLE SUR LES SOUS-RIGIDITES
  96. *======================================================================*
  97.         DO 200 IRI=1,NRIGEL
  98.  
  99.           IF(AFFICH)
  100.      &    WRITE(IOIMP,*)'MATRICE ',IRI,'IEME SOUS-RIGIDITE'
  101.  
  102.           IPT1   = IRIGEL(1,IRI)
  103.           DES1   = IRIGEL(3,IRI)
  104.           XMATRI = IRIGEL(4,IRI)
  105.           SEGACT,DES1,IPT1,XMATRI
  106.  
  107. *         Verification que la matrice est carr�e
  108.           NLIG1P=DES1.NOELEP(/1)
  109.           NLIG1D=DES1.NOELED(/1)
  110.           IF(NLIG1P.NE.NLIG1D) THEN
  111.             CALL ERREUR(756)
  112.             SEGDES,DES1,IPT1,XMATRI,MRIGID
  113.             RETURN
  114.           ENDIF
  115. *         rem : on pourrait aussi tester NOELEP(:) = NOELED(:)
  116. *                                        LISDUA(:) = dual de LISINC(:)
  117.           SEGACT,IPT1
  118.           NBNN1   = IPT1.NUM(/1)
  119.           NBELEM1 = IPT1.NUM(/2)
  120.  
  121.           IF(AFFICH) THEN
  122.             WRITE(IOIMP,*)'MATRICE : ',IRI,'IEME SOUS-RIGIDITE'
  123.             WRITE(IOIMP,*) '+INCO=',(DES1.LISINC(iou),iou=1,NLIG1P)
  124.             WRITE(IOIMP,*) '     #',(DES1.NOELEP(iou),iou=1,NLIG1P)
  125.           ENDIF
  126.  
  127. *         creation de KDDL = tableau local des ddls
  128.           NK=NLIG1P
  129.           SEGINI,KDDL
  130.  
  131.           XCOEF=COERIG(IRI)
  132.  
  133.  
  134. *----------------------------------------------------------------------*
  135. *         BOUCLE SUR LES ELEMENTS
  136. *----------------------------------------------------------------------*
  137.           DO 300 JEL=1,NBELEM1
  138.  
  139. *----------------------------------------------------------------------*
  140. *           BOUCLE SUR LES DDLS de cet element de cette sous matrice
  141. *----------------------------------------------------------------------*
  142.             DO 400 I=1,NLIG1P
  143.  
  144. c             recup du noeud + nom d'inconnue
  145.               INONO = DES1.NOELEP(I)
  146.               INONO2= DES1.NOELED(I)
  147.               MOPRI = DES1.LISINC(I)
  148.               MODUA = DES1.LISINC(I) 
  149.               IF(INONO.NE.INONO2) THEN
  150. c               La matrice de rigidite n'est pas carree 
  151.                 CALL ERREUR(756)
  152.                 RETURN
  153.               ENDIF
  154. c             rem : il faut aussi tester l'association primal-dual
  155.  
  156. c         --- NUMEROTATION LOCALE DES NOEUD ---
  157.               IP    = IPT1.NUM(INONO,JEL)
  158.               IPLOC = ICPR(IP)
  159. c             NOUVEAU NOEUD : ON L'AJOUTE 
  160.               IF(IPLOC.EQ.0) THEN
  161.                 NLOC =NLOC+1
  162.                 IF(NLOC.GT.NINCO) THEN
  163.                   NINCO=NINCO+10
  164.                   SEGADJ,KINCO
  165.                 ENDIF
  166.  
  167.                 IPLOC=NLOC
  168.                 ICPR(IP)=IPLOC
  169.               ELSE
  170.  
  171. c             NOEUD DEJA VU : IPLOC^ieme NOEUD LOCAL
  172.  
  173.               ENDIF
  174.  
  175.  
  176. c         --- NUMEROTATION LOCALE DES NOMS D'INCONNUES ---
  177.               DO 410 IILOC=1,JGM1
  178.                 IF(MOPRI.EQ.MLMOT1.MOTS(IILOC)) GOTO 411
  179. c               NOM D'INCONNUE DEJA VU : IILOC^ieme INCONNUE
  180.  410          CONTINUE
  181. c             NOUVEAU NOM D'INCONNUE : ON L'AJOUTE
  182.               JGM1 = JGM1 + 1
  183.               IF(JGM1.GT.MLMOT1.MOTS(/2)) THEN
  184.                 JGM = MLMOT1.MOTS(/2) + 10
  185.                 SEGADJ,MLMOT1,KINCO
  186.               ENDIF
  187.               IILOC= JGM1
  188.               MLMOT1.MOTS(IILOC)=MOPRI
  189.  411          CONTINUE
  190.  
  191. c         --- DDL = COUPLE NOEUD + NOM D'INCONNUE ---
  192.               IDDL=KINCO(IILOC,IPLOC)
  193.               IF(IDDL.EQ.0) THEN
  194.                 NDDL=NDDL+1
  195.                 IDDL=NDDL
  196.                 KINCO(IILOC,IPLOC)=IDDL
  197.               ENDIF
  198.  
  199. c             ON REMPLIT LE MELEME DE POI1 + LE MLMOTS
  200.               IF(IDDL.gt.NBELEM) THEN
  201.                 NBELEM=NBELEM+20
  202.                 SEGADJ,MELEME
  203.                 JGM=NBELEM
  204.                 SEGADJ,MLMOTS
  205.                 NLIGRD=NBELEM
  206.                 NLIGRP=NLIGRD
  207.                 rigrel=0
  208.                 SEGADJ,XMATR1,XMATR2                
  209.               ENDIF
  210.               NUM(1,IDDL)=IP
  211.               MOTS(IDDL)=MOPRI
  212.  
  213. c             ON REMPLIT AUSSI LE TABLEAU INVERSE KDDL
  214.               KDDL(I)=IDDL
  215.  
  216.  
  217.  
  218.  400      CONTINUE
  219. *----------------------------------------------------------------------*
  220. *         FIN DE BOUCLE SUR LES DDLS
  221. *----------------------------------------------------------------------*
  222.  
  223.           IF(AFFICH) THEN
  224.             WRITE(IOIMP,*) '+#DDL=',(KDDL(iou),iou=1,NLIG1P)
  225. c             WRITE(IOIMP,*) 'dim de XMATRI=',RE(/1),RE(/2),RE(/3)
  226.           ENDIF
  227.  
  228. *         REMPLISSAGE DES XMATR1
  229.           DO J=1,NLIG1P
  230.             JDDL = KDDL(J)
  231.             DO I=1,NLIG1P
  232.               IDDL = KDDL(I)
  233.               XMATR1.RE(IDDL,JDDL,1)
  234.      &      = XMATR1.RE(IDDL,JDDL,1) + XCOEF*RE(I,J,JEL)
  235.             ENDDO
  236.           ENDDO
  237.  
  238.  300      CONTINUE
  239. *----------------------------------------------------------------------*
  240. *         FIN DE BOUCLE SUR LES ELEMENTS
  241. *----------------------------------------------------------------------*
  242.  
  243.           SEGDES,DES1,IPT1,XMATRI
  244.  
  245.  200    CONTINUE
  246. *======================================================================*
  247. *       FIN DE BOUCLE SUR LES SOUS-RIGIDITES
  248. *======================================================================*
  249.  
  250.         SEGDES,MRIGID
  251.  
  252.  
  253. *======================================================================*
  254. *     MENAGE
  255. *======================================================================*
  256.       SEGSUP,KINCO,MLMOT1
  257. *      do i=1,ICPR(/1)
  258. *        ICPR(i)=0
  259. *      enddo
  260.  
  261. *======================================================================*
  262. *     FINALISATION DES OBJETS RESULTATS
  263. *======================================================================*
  264.  
  265.       if(NDDL.gt.NDDMAX) then
  266.         WRITE(IOIMP,*) 'Probleme de grande taille (',NDDL,'ddls):'
  267.         WRITE(IOIMP,*) 'L execution risque de prendre du temps...'
  268.       endif
  269.  
  270. *     MISE A LA BONNE DIMENSION DES OBJETS MELEME MLMOTS
  271.       NBELEM=NDDL
  272.       SEGADJ,MELEME
  273.       JGM=NDDL
  274.       SEGADJ,MLMOTS
  275.  
  276. *     MISE A LA BONNE DIMENSION DES OBJETS XMATR*
  277.       NLIGRD=NDDL
  278.       NLIGRP=NLIGRD
  279.       rigrel=0
  280.       SEGADJ,XMATR1,XMATR2
  281.  
  282. *     ECRITURE DE Id DANS XMATR2 (B)
  283.         DO IDDL=1,NDDL
  284.            XMATR2.RE(IDDL,IDDL,1) = 1.D0
  285.         ENDDO
  286.  
  287. *     AFFICHAGE DES OBJETS RESULTATS
  288.       IF (AFFICH) THEN
  289.         WRITE(IOIMP,*) 'MATRICE A ='
  290.         WRITE(IOIMP,*) (NUM(1,iou),iou=1,NBELEM)
  291.         WRITE(IOIMP,*) (MOTS(iou),iou=1,JGM)
  292.         DO iou=1,NDDL
  293.            WRITE(IOIMP,*) (XMATR1.RE(iou,jou),jou=1,NDDL)
  294.         ENDDO
  295.         WRITE(IOIMP,*) 'MATRICE B ='
  296.         WRITE(IOIMP,*) (NUM(1,iou),iou=1,NBELEM)
  297.         WRITE(IOIMP,*) (MOTS(iou),iou=1,JGM)
  298.         DO iou=1,NDDL
  299.            WRITE(IOIMP,*) (XMATR2.RE(iou,jou),jou=1,NDDL)
  300.         ENDDO
  301.       ENDIF
  302. *
  303. *======================================================================*
  304. *     MENAGE
  305. *======================================================================*
  306.       SEGSUP,ICPR
  307.  
  308.       RETURN
  309.       END
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322.  

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