Télécharger la plaquette Cast3M


fr en

Télécharger asse10.eso

Retour à la liste

Numérotation des lignes : 

asse10

  1. C ASSE10    SOURCE    MB234859  26/06/10    21:15:05     12569          
  2. C ASSEM0    SOURCE    PV        99/03/11    21:16:48     3517
  3.       SUBROUTINE ASSE10(MRIGI1,ICLE,MDNO,MIMI,MINCP,INUIN1,inwuit)
  4.       IMPLICIT INTEGER(I-N)
  5.       IMPLICIT REAL*8 (A-H,O-Z)
  6.  
  7.  
  8. -INC PPARAM
  9. -INC CCOPTIO
  10. -INC SMRIGID
  11. -INC SMLMOTS
  12. -INC SMLREEL
  13. -INC SMLENTI
  14. -INC SMMATRI
  15. -INC SMELEME
  16. *  ICLE=1
  17. * ce subroutine a pour fonction d'initialiser le segment de
  18. * normalisation MDNOR et de fabriquer les matrices normalisees pour
  19. * les transferer a l'assemblage.
  20. *  ICLE=2
  21. *  destructions des matrices normalisees
  22. *
  23.       SEGMENT,INUINV(NNGLOB)
  24.       SEGMENT MICOR(NLIGRP)
  25.       SEGMENT INWAIT
  26.          INTEGER IIM(IRM)
  27.       ENDSEGMENT
  28.  
  29. *       write(6,fmt='(''  entree dans asse10 icle'',i6)') icle
  30.  
  31.       IF(ICLE.EQ.1) THEN
  32. C
  33. C   on est en premier passage il faut triturer les matrices
  34. C
  35.          MRIGID=MRIGI1
  36.          SEGACT MRIGID*MOD
  37.  
  38. *      write(6,fmt='(''  entree dans assem0 mrigi1 ichole  ''
  39. *     * ,2i6)')
  40. *     *  mrigid,ichole
  41.  
  42.          IRM=IRIGEL(/2)
  43.          SEGINI INWAIT
  44.          inwuit=inwait
  45.          MLMOTS=NORINC
  46.  
  47. *      write( 6,fmt='('' assem0 norinc '', i6)') norinc
  48.        INUINV=INUIN1
  49.        SEGACT INUINV
  50.        MDNOR=MDNO
  51.        SEGACT MDNOR*MOD
  52.        MINCPO=MINCP
  53.        SEGACT MINCPO
  54.        ID1=INCPO(/1)
  55.        ID2=INCPO(/2)
  56.        MIMIK=MIMI
  57.        SEGACT MIMIK
  58.  
  59. C    ... Si la normalisation est AUTOmatique ...
  60.  
  61.          IF(MLMOTS.EQ. -1) THEN
  62.             JG=20
  63.             JGN=4
  64.             JGM=20
  65.             JFIN=0
  66.             JMAX=20
  67. *            SEGINI MLMOTS,MLREEL
  68. *            CALL SAVSEG(MLMOTS)
  69. *            CALL SAVSEG(MLREEL)
  70.             DO 50 I=1,IRM
  71.                DESCR=IRIGEL(3,I)
  72.                SEGACT DESCR
  73.                NLIGRP=NOELEP(/1)
  74.                NLIGRD=NLIGRP
  75.                JG=NLIGRP
  76.                SEGINI MICOR
  77. *
  78.              DO 51 J=1,NLIGRP
  79.                   DO 52 K=1,ID1
  80.                   IF(IMIK(K).EQ.LISINC(J)) GO TO 590
  81.    52             CONTINUE
  82.                  call erreur(5)
  83.   590          CONTINUE
  84.                MICOR(J)=K
  85.    51       CONTINUE
  86.             MELEME=IRIGEL(1,I)
  87.             SEGACT MELEME
  88.             XMATRI=IRIGEL(4,I)
  89.             segact Xmatri
  90. * on balaye toutes les matrices pour simuler l'assemblage du terme diagonale
  91.             DO 53 J=1,RE(/3)
  92. *                  XMATRI=IMATTT(J)
  93.                    SEGACT XMATRI
  94.                   DO 54 K=1,NLIGRP
  95.                    Ia = INUINV(NUM(NOELEP(K),J))
  96.                    inc = INCPO(MICOR(K),ia)
  97.                    dnor(inc)=dnor(inc)+re(K,K,j)
  98.    54             CONTINUE
  99.                   SEGDES XMATRI
  100.    53       CONTINUE
  101. *           SEGDES MELEME
  102.    50       CONTINUE
  103.  
  104.          ILX=0
  105.          DO 56 IU=1,IMIK(/2)
  106.           IF( IMIK(IU).EQ.'LX  ') then
  107.              ILX=IU
  108.              GO TO 57
  109.           ENDIF
  110.    56  CONTINUE
  111.    57  CONTINUE
  112. *       write(6,*) ' ilx',ilx
  113. *       write(6,*) ' imik' ,( imik(iuo),iuo=1,imik(/2))
  114. C       ... Les coefficients valent 0.8/sqrt(terme maxi) pour les DDL
  115. C           "physiques" et 1 pour les multiplicateurs de Lagrange ...
  116.          DO 58  IO = 1, ID2
  117.           DO 59 IOP = 1 , ID1
  118.             IA = incpo(IOP,IO)
  119.              IF(IA.NE.0) THEN
  120.                IF(IOP.EQ.ILX) THEN
  121.                  DNOR(IA)=1.D0
  122.               ELSE
  123.                 IF(DNOR(IA).EQ.0.D0) DNOR(IA)=1.D0
  124.                 DNOR(IA)=0.8D0 / SQRT(ABS(DNOR(IA)))
  125. *                dnor(IA)=1.d-4 * IO
  126.               ENDIF
  127.            ENDIF
  128.   59  CONTINUE
  129.    58 CONTINUE
  130. C    ... Sinon (cad. la normalisation n'est pas automatique) ...
  131.          ELSE
  132.             SEGACT MLMOTS
  133.             LIN=MOTS(/2)
  134.             MLREEL=NORVAL
  135.             SEGACT MLREEL
  136.             MLMOT1=NORIND
  137.             MLREE1=NORVAD
  138.  
  139.               DO 61 IOP=1,ID1
  140.             do 62 IU=1,MOTS(/2)
  141.                IPL=IU
  142.                IF(IMIK(IOP).EQ.MOTS(IU) ) go to 63
  143.    62       CONTINUE
  144.             xre=1.D0
  145.             GO TO 64
  146.    63       XRE = PROG(IPL)
  147.    64       CONTINUE
  148.             do 65 io = 1,ID2
  149.             IA = INCPO(Iop,io)
  150.              IF(IA.EQ.0) GO TO 65
  151.             DNOR(IA) = xre
  152.    65       CONTINUE
  153.    61      CONTINUE
  154.        ENDIF
  155.  
  156. C ... La normalisation proprement dite commence ici ...
  157. C
  158. C   BOUCLE 1 SUR LES SOUS ZONES ELEMENTAIRES sans reflechir on multiplie
  159. C  toutes les matrices par dnor
  160. C
  161. *         write(6,*) ' dnor',(dnor(IUO),IUO=1,dnor(/1))
  162.          DO 1 I=1,IRM
  163.             DESCR=IRIGEL(3,I)
  164.             SEGACT DESCR
  165.             NLIGRP=NOELEP(/1)
  166.             NLIGRD=NLIGRP
  167.             JG=NLIGRP
  168.             segini mlenti
  169.             meleme=irigel(1,I)
  170.             segact meleme
  171. C
  172. C   existe-t-il des inconnues a normer dans la matrice  OUI!
  173. C   si oui création de MLREE2 ET MLREE3 qui serviront de coef
  174. C   multiplicateurs a partir de dnor
  175. C
  176. C
  177. C  il faut multiplier les matrices
  178. C  On va le faire et on cree un nouveau segment IMATRI
  179. C  l'ancien etant stocke dans inwait
  180. C
  181.             XMATRI=IRIGEL(4,I)
  182.             SEGACT XMATRI
  183.             NELRIG=RE(/3)
  184. C       ... On met le pointeur IMATRI dans INWAIT ...
  185.             IIM(I)=XMATRI
  186. C       ... On créé un nouveau IMATRI et on le met dans MRIGID ...
  187.             SEGINI,XMATR1=xmatri
  188.             IRIGEL(4,I)=xMATR1
  189. C       ... Puis on parcourt les matrices élémentaires ...
  190.             DO 3 IU=1,LISINC(/2)
  191.             DO 2 IO=1,IMIK(/2)
  192.               IF(LISINC(IU).EQ.IMIK(IO)) go to 4
  193.     2       CONTINUE
  194.              CALL ERREUR(5)
  195.     4       CONTINUE
  196.             LECT(IU)=IO
  197.     3       CONTINUE
  198. *           write(6,*)   ' lect', (lect(Iuo),iuo=1,lect(/1))
  199.             DO 7 K=1,NELRIG
  200. C          ... Boucle sur les variables duales ...
  201.                 do 8 L=1,NLIGRP
  202.                 IAB=INUINV(NUM(NOELEP(L),K))
  203.                 INH= INCPO(LECT(L),IAB)
  204.                   COE=DNOR(INH)
  205.                   IF(COE.EQ.1.D0) GO TO 8
  206. C             ... Si le coefficient est différent de 1 ...
  207.                   DO 9 M=1,NLIGRP
  208. C                ... On multiplie la ligne N° L par ce coeff. ...
  209.                      XMATR1.RE(L,M,k)=XMATR1.RE(L,M,k)*COE
  210.                      XMATR1.RE(M,L,k)=XMATR1.RE(M,L,k)*COE
  211.    9              CONTINUE
  212.    8           CONTINUE
  213.     7       CONTINUE
  214. C       ... Ménage ...
  215.             SEGDES,XMATRI,XMATR1
  216.             SEGSUP MLENTI
  217.     1    CONTINUE
  218. *        write(6,*) ' asse10  dnor'
  219. *      write(6,*) ( dnor(IUO),iuo=1,100)
  220.  
  221. *      write(6,fmt='('' assem0 norinc norval norind norvad'',4i6)
  222. *     * ') norinc,norval,norind,norvad
  223.  
  224. *         SEGDES INWAIT
  225. *         SEGDES MRIGID
  226.  
  227.       ELSEIF(ICLE.EQ.2) THEN
  228.  
  229. *        write(6,fmt='('' assem0   inwait '' ,i6 )') inwait
  230.  
  231. C    ... Destruction des matrices normalisées et remise dans MRIGID
  232. C        des matrices d'origine conservées dans INWAIT ...
  233.          inwait=inwuit
  234.          IF(INWAIT.EQ.0) RETURN
  235.          SEGACT INWAIT
  236.          MRIGID=MRIGI1
  237.          SEGACT MRIGID*MOD
  238.          DO 20 I=1,IIM(/1)
  239.             IF(IIM(I).EQ.0) GO TO 20
  240.             XMATRI=IRIGEL(4,I)
  241.             SEGSUP XMATRI
  242. *            DO 21 L=1,IMATTT(/1)
  243. *               XMATRI=IMATTT(L)
  244. *               SEGSUP XMATRI
  245. *   21       CONTINUE
  246. *            SEGSUP IMATRI
  247.             IRIGEL(4,I) = IIM(I)
  248.    20    CONTINUE
  249.          SEGSUP INWAIT
  250.          SEGDES MRIGID
  251.          INWUIT=0
  252.       ENDIF
  253.  
  254. *      write(6,fmt='(''  sortie assem0  norinc norval'',2i6)')
  255. *     *  norinc,norval
  256. *      mlmots = norinc
  257. *      mlreel = norval
  258. *      segact mlmots,mlreel
  259. *      write(6,fmt='(''  sortie assem0  definitive'')')
  260.  
  261.       RETURN
  262.       END
  263.  
  264.  

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