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    BP208322  22/09/22    21:15:04     11464          
  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.       SEGINI,XMATR1,XMATR2
  63.  
  64. *     de ICPR = tableau de la numerotation locale
  65.       SEGACT MCOORD*mod
  66.       SEGINI,ICPR
  67.       NLOC=0
  68.  
  69. *     de MLMOT1 = tableau des noms d'inconnue locale
  70.       JGN=4
  71.       JGM=10
  72.       SEGINI,MLMOT1
  73.       JGM1=0
  74.  
  75. *     de KINCO = tableau des ddls
  76.       NINCO=10
  77.       SEGINI KINCO
  78.  
  79. *     nombre total de DDL :      
  80.       NDDL=0
  81.  
  82.  
  83. *======================================================================*
  84. *     RIGIDITE en entree
  85. *======================================================================*
  86.  
  87.         MRIGID=RI1
  88.         IF(MRIGID.EQ.0) CALL ERREUR(5)
  89.  
  90.         SEGACT,MRIGID
  91.         NRIGEL=IRIGEL(/2)
  92.  
  93. *======================================================================*
  94. *       BOUCLE SUR LES SOUS-RIGIDITES
  95. *======================================================================*
  96.         DO 200 IRI=1,NRIGEL
  97.  
  98.           IF(AFFICH)
  99.      &    WRITE(IOIMP,*)'MATRICE ',IRI,'IEME SOUS-RIGIDITE'
  100.  
  101.           IPT1   = IRIGEL(1,IRI)
  102.           DES1   = IRIGEL(3,IRI)
  103.           XMATRI = IRIGEL(4,IRI)
  104.           SEGACT,DES1,IPT1,XMATRI
  105.  
  106. *         Verification que la matrice est carr�e
  107.           NLIG1P=DES1.NOELEP(/1)
  108.           NLIG1D=DES1.NOELED(/1)
  109.           IF(NLIG1P.NE.NLIG1D) THEN
  110.             CALL ERREUR(756)
  111.             SEGDES,DES1,IPT1,XMATRI,MRIGID
  112.             RETURN
  113.           ENDIF
  114. *         rem : on pourrait aussi tester NOELEP(:) = NOELED(:)
  115. *                                        LISDUA(:) = dual de LISINC(:)
  116.           SEGACT,IPT1
  117.           NBNN1   = IPT1.NUM(/1)
  118.           NBELEM1 = IPT1.NUM(/2)
  119.  
  120.           IF(AFFICH) THEN
  121.             WRITE(IOIMP,*)'MATRICE : ',IRI,'IEME SOUS-RIGIDITE'
  122.             WRITE(IOIMP,*) '+INCO=',(DES1.LISINC(iou),iou=1,NLIG1P)
  123.             WRITE(IOIMP,*) '     #',(DES1.NOELEP(iou),iou=1,NLIG1P)
  124.           ENDIF
  125.  
  126. *         creation de KDDL = tableau local des ddls
  127.           NK=NLIG1P
  128.           SEGINI,KDDL
  129.  
  130.           XCOEF=COERIG(IRI)
  131.  
  132.  
  133. *----------------------------------------------------------------------*
  134. *         BOUCLE SUR LES ELEMENTS
  135. *----------------------------------------------------------------------*
  136.           DO 300 JEL=1,NBELEM1
  137.  
  138. *----------------------------------------------------------------------*
  139. *           BOUCLE SUR LES DDLS de cet element de cette sous matrice
  140. *----------------------------------------------------------------------*
  141.             DO 400 I=1,NLIG1P
  142.  
  143. c             recup du noeud + nom d'inconnue
  144.               INONO = DES1.NOELEP(I)
  145.               INONO2= DES1.NOELED(I)
  146.               MOPRI = DES1.LISINC(I)
  147.               MODUA = DES1.LISINC(I) 
  148.               IF(INONO.NE.INONO2) THEN
  149. c               La matrice de rigidite n'est pas carree 
  150.                 CALL ERREUR(756)
  151.                 RETURN
  152.               ENDIF
  153. c             rem : il faut aussi tester l'association primal-dual
  154.  
  155. c         --- NUMEROTATION LOCALE DES NOEUD ---
  156.               IP    = IPT1.NUM(INONO,JEL)
  157.               IPLOC = ICPR(IP)
  158. c             NOUVEAU NOEUD : ON L'AJOUTE 
  159.               IF(IPLOC.EQ.0) THEN
  160.                 NLOC =NLOC+1
  161.                 IF(NLOC.GT.NINCO) THEN
  162.                   NINCO=NINCO+10
  163.                   SEGADJ,KINCO
  164.                 ENDIF
  165.  
  166.                 IPLOC=NLOC
  167.                 ICPR(IP)=IPLOC
  168.               ELSE
  169.  
  170. c             NOEUD DEJA VU : IPLOC^ieme NOEUD LOCAL
  171.  
  172.               ENDIF
  173.  
  174.  
  175. c         --- NUMEROTATION LOCALE DES NOMS D'INCONNUES ---
  176.               DO 410 IILOC=1,JGM1
  177.                 IF(MOPRI.EQ.MLMOT1.MOTS(IILOC)) GOTO 411
  178. c               NOM D'INCONNUE DEJA VU : IILOC^ieme INCONNUE
  179.  410          CONTINUE
  180. c             NOUVEAU NOM D'INCONNUE : ON L'AJOUTE
  181.               JGM1 = JGM1 + 1
  182.               IF(JGM1.GT.MLMOT1.MOTS(/2)) THEN
  183.                 JGM = MLMOT1.MOTS(/2) + 10
  184.                 SEGADJ,MLMOT1,KINCO
  185.               ENDIF
  186.               IILOC= JGM1
  187.               MLMOT1.MOTS(IILOC)=MOPRI
  188.  411          CONTINUE
  189.  
  190. c         --- DDL = COUPLE NOEUD + NOM D'INCONNUE ---
  191.               IDDL=KINCO(IILOC,IPLOC)
  192.               IF(IDDL.EQ.0) THEN
  193.                 NDDL=NDDL+1
  194.                 IDDL=NDDL
  195.                 KINCO(IILOC,IPLOC)=IDDL
  196.               ENDIF
  197.  
  198. c             ON REMPLIT LE MELEME DE POI1 + LE MLMOTS
  199.               IF(IDDL.gt.NBELEM) THEN
  200.                 NBELEM=NBELEM+20
  201.                 SEGADJ,MELEME
  202.                 JGM=NBELEM
  203.                 SEGADJ,MLMOTS
  204.                 NLIGRD=NBELEM
  205.                 NLIGRP=NLIGRD
  206.                 SEGADJ,XMATR1,XMATR2                
  207.               ENDIF
  208.               NUM(1,IDDL)=IP
  209.               MOTS(IDDL)=MOPRI
  210.  
  211. c             ON REMPLIT AUSSI LE TABLEAU INVERSE KDDL
  212.               KDDL(I)=IDDL
  213.  
  214.  
  215.  
  216.  400      CONTINUE
  217. *----------------------------------------------------------------------*
  218. *         FIN DE BOUCLE SUR LES DDLS
  219. *----------------------------------------------------------------------*
  220.  
  221.           IF(AFFICH) THEN
  222.             WRITE(IOIMP,*) '+#DDL=',(KDDL(iou),iou=1,NLIG1P)
  223. c             WRITE(IOIMP,*) 'dim de XMATRI=',RE(/1),RE(/2),RE(/3)
  224.           ENDIF
  225.  
  226. *         REMPLISSAGE DES XMATR1
  227.           DO J=1,NLIG1P
  228.             JDDL = KDDL(J)
  229.             DO I=1,NLIG1P
  230.               IDDL = KDDL(I)
  231.               XMATR1.RE(IDDL,JDDL,1)
  232.      &      = XMATR1.RE(IDDL,JDDL,1) + XCOEF*RE(I,J,JEL)
  233.             ENDDO
  234.           ENDDO
  235.  
  236.  300      CONTINUE
  237. *----------------------------------------------------------------------*
  238. *         FIN DE BOUCLE SUR LES ELEMENTS
  239. *----------------------------------------------------------------------*
  240.  
  241.           SEGDES,DES1,IPT1,XMATRI
  242.  
  243.  200    CONTINUE
  244. *======================================================================*
  245. *       FIN DE BOUCLE SUR LES SOUS-RIGIDITES
  246. *======================================================================*
  247.  
  248.         SEGDES,MRIGID
  249.  
  250.  
  251. *======================================================================*
  252. *     MENAGE
  253. *======================================================================*
  254.       SEGSUP,KINCO,MLMOT1
  255. *      do i=1,ICPR(/1)
  256. *        ICPR(i)=0
  257. *      enddo
  258.  
  259. *======================================================================*
  260. *     FINALISATION DES OBJETS RESULTATS
  261. *======================================================================*
  262.  
  263.       if(NDDL.gt.NDDMAX) then
  264.         WRITE(IOIMP,*) 'Probleme de grande taille (',NDDL,'ddls):'
  265.         WRITE(IOIMP,*) 'L execution risque de prendre du temps...'
  266.       endif
  267.  
  268. *     MISE A LA BONNE DIMENSION DES OBJETS MELEME MLMOTS
  269.       NBELEM=NDDL
  270.       SEGADJ,MELEME
  271.       JGM=NDDL
  272.       SEGADJ,MLMOTS
  273.  
  274. *     MISE A LA BONNE DIMENSION DES OBJETS XMATR*
  275.       NLIGRD=NDDL
  276.       NLIGRP=NLIGRD
  277.       SEGADJ,XMATR1,XMATR2
  278.  
  279. *     ECRITURE DE Id DANS XMATR2 (B)
  280.         DO IDDL=1,NDDL
  281.            XMATR2.RE(IDDL,IDDL,1) = 1.D0
  282.         ENDDO
  283.  
  284. *     AFFICHAGE DES OBJETS RESULTATS
  285.       IF (AFFICH) THEN
  286.         WRITE(IOIMP,*) 'MATRICE A ='
  287.         WRITE(IOIMP,*) (NUM(1,iou),iou=1,NBELEM)
  288.         WRITE(IOIMP,*) (MOTS(iou),iou=1,JGM)
  289.         DO iou=1,NDDL
  290.            WRITE(IOIMP,*) (XMATR1.RE(iou,jou),jou=1,NDDL)
  291.         ENDDO
  292.         WRITE(IOIMP,*) 'MATRICE B ='
  293.         WRITE(IOIMP,*) (NUM(1,iou),iou=1,NBELEM)
  294.         WRITE(IOIMP,*) (MOTS(iou),iou=1,JGM)
  295.         DO iou=1,NDDL
  296.            WRITE(IOIMP,*) (XMATR2.RE(iou,jou),jou=1,NDDL)
  297.         ENDDO
  298.       ENDIF
  299. *
  300. *======================================================================*
  301. *     MENAGE
  302. *======================================================================*
  303.       SEGSUP,ICPR
  304.  
  305.       RETURN
  306.       END
  307.  
  308.  
  309.  
  310.  
  311.  
  312.  
  313.  
  314.  
  315.  
  316.  
  317.  

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