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

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