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

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